grew_command.ml 5.9 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
  type command_node =        (* a command node is either: *)
12 13 14
    | 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
  type item =
17
    | Feat of (command_node * string)
18
    | 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
  (* the command in pattern *)
  type p = 
24 25
    | DEL_NODE of command_node
    | DEL_EDGE_EXPL of (command_node * command_node * G_edge.t)
pj2m's avatar
pj2m committed
26
    | DEL_EDGE_NAME of string
27 28 29
    | ADD_EDGE of (command_node * command_node * G_edge.t)
    | DEL_FEAT of (command_node * string)
    | UPDATE_FEAT of (command_node * string * item list)
30
    | NEW_NEIGHBOUR of (string * G_edge.t * Pid.t)
31 32 33 34
    | SHIFT_EDGE of (command_node * command_node)
    | SHIFT_IN of (command_node * command_node)
    | SHIFT_OUT of (command_node * command_node)
    | MERGE_NODE of (command_node * command_node)
pj2m's avatar
pj2m committed
35 36 37 38 39

  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
    | 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)

52
  let build ?param (kai, kei) table locals ast_command =
53

54
    let pid_of_act_id = function
55
        | (node_name, None) -> Pat (Pid.Pos (Id.build node_name table))
56
        | (node_name, Some n) -> Act (Pid.Pos (Id.build node_name table), n) in
57

58 59 60
    let check_act_id loc act_id kai =
      if not (List.mem act_id kai)
      then Error.build ~loc "Unbound node identifier \"%s\"" (Ast.act_id_to_string act_id) 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 (act_i, act_j, lab), loc) ->
        check_act_id loc act_i kai;
        check_act_id loc act_j kai;
70
	let edge = G_edge.make ~loc ~locals lab in
71
	((DEL_EDGE_EXPL (pid_of_act_id act_i, pid_of_act_id act_j, edge), loc), (kai, 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), (kai, List_.rm id kei)
pj2m's avatar
pj2m committed
76

77 78 79
      | (Ast.Add_edge (act_i, act_j, lab), loc) ->
        check_act_id loc act_i kai;
        check_act_id loc act_j kai;
80
	let edge = G_edge.make ~loc ~locals lab in
81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106
	((ADD_EDGE (pid_of_act_id act_i, pid_of_act_id act_j, edge), loc), (kai, kei))

      | (Ast.Shift_edge (act_i, act_j), loc) ->
        check_act_id loc act_i kai;
        check_act_id loc act_j kai;
	((SHIFT_EDGE (pid_of_act_id act_i, pid_of_act_id act_j), loc), (kai, kei))

      | (Ast.Shift_in (act_i, act_j), loc) ->
        check_act_id loc act_i kai;
        check_act_id loc act_j kai;
	((SHIFT_IN (pid_of_act_id act_i, pid_of_act_id act_j), loc), (kai, kei))

      | (Ast.Shift_out (act_i, act_j), loc) ->
        check_act_id loc act_i kai;
        check_act_id loc act_j kai;
	((SHIFT_OUT (pid_of_act_id act_i, pid_of_act_id act_j), loc), (kai, kei))

      | (Ast.Merge_node (act_i, act_j), loc) ->
        check_act_id loc act_i kai;
        check_act_id loc act_j kai;
	((MERGE_NODE (pid_of_act_id act_i, pid_of_act_id act_j), loc), (List_.rm act_i kai, kei))

      | (Ast.New_neighbour (new_id, ancestor, label), loc) ->
        check_act_id loc ancestor kai;
        if List.mem (new_id, None) kai
        then Error.build ~loc "Node identifier \"%s\" is already used" new_id;
bguillaum's avatar
bguillaum committed
107
	let edge = G_edge.make ~loc ~locals label in
pj2m's avatar
pj2m committed
108
	begin
bguillaum's avatar
bguillaum committed
109 110 111
	  try
            (
              (NEW_NEIGHBOUR
112
                 (new_id,
bguillaum's avatar
bguillaum committed
113
                  edge,
114
                  Pid.Pos (Id.build ~loc (fst ancestor) table)
bguillaum's avatar
bguillaum committed
115
                 ), loc),
116
              ((new_id, None)::kai, 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
	      (Loc.to_string loc)
	end
124 125

      | (Ast.Activate n, loc) -> failwith "Not implemented"
pj2m's avatar
pj2m committed
126
	  
127 128 129
      | (Ast.Del_node act_n, loc) ->
        check_act_id loc act_n kai;
        ((DEL_NODE (pid_of_act_id act_n), loc), (List_.rm act_n kai, kei))
pj2m's avatar
pj2m committed
130
	  
131 132 133
      | (Ast.Del_feat (act_id, feat_name), loc) ->
        check_act_id loc act_id kai;
        ((DEL_FEAT (pid_of_act_id act_id, feat_name), loc), (kai, kei))
bguillaum's avatar
bguillaum committed
134

135 136
      | (Ast.Update_feat ((act_id, feat_name), ast_items), loc) ->
        check_act_id loc act_id kai;
137
        let items = List.map 
138
          (function
139 140 141 142 143
            (* special case of a basic identifier understood as a string *)
            | Ast.Qfn_item ci when Ast.is_simple ci -> String (Ast.complex_id_to_string ci)
            | Ast.Qfn_item ci ->
              let (act_id,feature_name) = Ast.act_qfn_of_ci ci in
              check_act_id loc act_id kai; Feat (pid_of_act_id act_id, feature_name)
144 145 146 147 148 149 150 151 152 153
            | 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
154
        ((UPDATE_FEAT (pid_of_act_id act_id, feat_name, items), loc), (kai, kei))
155
end (* module Command *)