grew_command.ml 5.44 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
(* ==================================================================================================== *)
pj2m's avatar
pj2m committed
10
module Command  = struct 
11 12 13 14
  type cnode =               (* a command node is either: *)
    | Pat of Pid.t           (* a node identified in the pattern *)
    | New of string          (* a node introduced by a new_neighbour *)
    | Act of Pid.t * string  (* a node introduced by a activate *)
pj2m's avatar
pj2m committed
15

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

pj2m's avatar
pj2m committed
22 23 24
  (* the command in pattern *)
  type p = 
    | DEL_NODE of cnode
25
    | DEL_EDGE_EXPL of (cnode * cnode * G_edge.t) 
pj2m's avatar
pj2m committed
26
    | DEL_EDGE_NAME of string
27
    | ADD_EDGE of (cnode * cnode * G_edge.t)
bguillaum's avatar
bguillaum committed
28
    | DEL_FEAT of (cnode * string)
29
    | UPDATE_FEAT of (cnode * string * item list)
30
    | NEW_NEIGHBOUR of (string * G_edge.t * Pid.t)
pj2m's avatar
pj2m committed
31
    | SHIFT_EDGE of (cnode * cnode)
32 33
    | SHIFT_IN of (cnode * cnode)
    | SHIFT_OUT of (cnode * cnode)
pj2m's avatar
pj2m committed
34 35 36 37 38 39
    | 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 = 
40 41
    | H_DEL_NODE of Gid.t
    | H_DEL_EDGE_EXPL of (Gid.t * Gid.t *G_edge.t)
pj2m's avatar
pj2m committed
42
    | H_DEL_EDGE_NAME of string
43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60
    | H_ADD_EDGE of (Gid.t * Gid.t * G_edge.t)
    | H_DEL_FEAT of (Gid.t * string)
    | H_UPDATE_FEAT of (Gid.t * string * string)
    | H_NEW_NEIGHBOUR of (string * G_edge.t * Gid.t)
    | H_SHIFT_EDGE of (Gid.t * Gid.t)
    | H_SHIFT_IN of (Gid.t * Gid.t)
    | H_SHIFT_OUT of (Gid.t * Gid.t)
    | H_MERGE_NODE of (Gid.t * Gid.t)

  let build ?param (kci, kei) table locals ast_command =

    let pid_of_c_ident = function
        | (node_name, None) -> Pat (Pid.Pos (Id.build node_name table))
        | (node_name, Some n) ->  Act (Pid.Pos (Id.build node_name table), n) in

    let check_c_ident loc c_ident kci =
      if not (List.mem c_ident kci)
      then Error.build ~loc "Unbound c_ident identifier \"%s\"" (Ast.c_ident_to_string c_ident) in
61 62 63 64 65

    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
66
    match ast_command with
67 68 69
      | (Ast.Del_edge_expl (i, j, lab), loc) ->
        check_c_ident loc i kci;
        check_c_ident loc j kci;
70
	let edge = G_edge.make ~locals lab in
71
	((DEL_EDGE_EXPL (pid_of_c_ident i, pid_of_c_ident j, edge), loc), (kci, kei))
pj2m's avatar
pj2m committed
72
	  
73
      | (Ast.Del_edge_name id, loc) ->
74
        check_edge loc id kei;
75
        (DEL_EDGE_NAME id, loc), (kci, List_.rm id kei)
pj2m's avatar
pj2m committed
76
	  
77 78 79
      | (Ast.Add_edge (i, j, lab), loc) ->
        check_c_ident loc i kci;
        check_c_ident loc j kci;
80
	let edge = G_edge.make ~locals lab in
81
	((ADD_EDGE (pid_of_c_ident i, pid_of_c_ident j, edge), loc), (kci, kei))
pj2m's avatar
pj2m committed
82

83 84 85 86
      | (Ast.Shift_edge (i, j), loc) ->
        check_c_ident loc i kci;
        check_c_ident loc j kci;
	((SHIFT_EDGE (pid_of_c_ident i, pid_of_c_ident j), loc), (kci, kei))
87

88 89 90 91
      | (Ast.Shift_in (i, j), loc) ->
        check_c_ident loc i kci;
        check_c_ident loc j kci;
	((SHIFT_IN (pid_of_c_ident i, pid_of_c_ident j), loc), (kci, kei))
92

93 94 95 96 97 98 99 100 101 102 103 104 105
      | (Ast.Shift_out (i, j), loc) ->
        check_c_ident loc i kci;
        check_c_ident loc j kci;
	((SHIFT_OUT (pid_of_c_ident i, pid_of_c_ident j), loc), (kci, kei))

      | (Ast.Merge_node (i, j), loc) ->
        check_c_ident loc i kci;
        check_c_ident loc j kci;
	((MERGE_NODE (pid_of_c_ident i, pid_of_c_ident j), loc), (List_.rm i kci, kei))

      | (Ast.New_neighbour ((name_created, None), ancestor, label), loc) ->
        check_c_ident loc ancestor kci;
        if List.mem (name_created, None) kci
106
        then Error.build ~loc "Node identifier \"%s\" is already used" name_created;
107
	let edge = G_edge.make ~locals label in
pj2m's avatar
pj2m committed
108
	begin
bguillaum's avatar
bguillaum committed
109 110 111 112 113
	  try
            (
              (NEW_NEIGHBOUR
                 (name_created,
                  edge,
114
                  Pid.Pos (Id.build ~loc (fst ancestor) table)
bguillaum's avatar
bguillaum committed
115
                 ), loc),
116
              ((name_created, None)::kci, kei)
bguillaum's avatar
bguillaum committed
117
            )
pj2m's avatar
pj2m committed
118 119
	  with Not_found -> 
	    Log.fcritical "[GRS] tries to build a command New_neighbour (%s) on node %s which is not in the pattern %s"
120
	      (G_edge.to_string edge)
121
	      (fst ancestor)
pj2m's avatar
pj2m committed
122 123 124
	      (Loc.to_string loc)
	end
	  
125 126 127
      | (Ast.Del_node n, loc) ->
        check_c_ident loc n kci;
	((DEL_NODE (pid_of_c_ident n), loc), (List_.rm n kci, kei))
pj2m's avatar
pj2m committed
128
	  
129 130 131
      | (Ast.Del_feat (c_ident,feat_name), loc) ->
        check_c_ident loc c_ident kci;
        ((DEL_FEAT (pid_of_c_ident c_ident, feat_name), loc), (kci, kei))
bguillaum's avatar
bguillaum committed
132

133 134
      | (Ast.Update_feat ((c_ident, feat_name), ast_items), loc) ->
        check_c_ident loc c_ident kci;
135
        let items = List.map 
136 137 138 139 140 141 142 143 144 145 146 147 148 149 150
          (function
            | Ast.Qfn_item (ci,fn) -> check_c_ident loc ci kci; Feat (pid_of_c_ident ci, fn)
            | Ast.String_item s -> String s
            | Ast.Param_item var ->
              match param with
                | None -> Error.build "Unknown command variable '%s'" var
                | 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
          ) ast_items in
        ((UPDATE_FEAT (pid_of_c_ident c_ident, feat_name, items), loc), (kci, kei))
      | _ -> failwith "TODO remove with new neighbour"
end (* module Command *)