Commit e86ca5d2 authored by Bruno Guillaume's avatar Bruno Guillaume

code rewriting

parent 40b093d0
...@@ -20,9 +20,9 @@ open Grew_fs ...@@ -20,9 +20,9 @@ open Grew_fs
(* ================================================================================ *) (* ================================================================================ *)
module Command = struct module Command = struct
type command_node = (* a command node is either: *) type command_node = (* a command node is either: *)
| Pat of Pid.t (* a node identified in the pattern *) | Pat of Pid.t (* a node identified in the pattern *)
| New of string (* a node introduced by a new_neighbour *) (* TODO: remove *) | New of string (* a node introduced by a add_node *)
let command_node_to_json = function let command_node_to_json = function
| Pat pid -> `String (Pid.to_string pid) | Pat pid -> `String (Pid.to_string pid)
...@@ -55,11 +55,11 @@ module Command = struct ...@@ -55,11 +55,11 @@ module Command = struct
| ADD_EDGE_EXPL of (command_node * command_node * string) | ADD_EDGE_EXPL of (command_node * command_node * string)
| DEL_FEAT of (command_node * string) | DEL_FEAT of (command_node * string)
| UPDATE_FEAT of (command_node * string * item list) | UPDATE_FEAT of (command_node * string * item list)
(* *)
| NEW_NODE of string | NEW_NODE of string
| NEW_BEFORE of (string * command_node) | NEW_BEFORE of (string * command_node)
| NEW_AFTER of (string * command_node) | NEW_AFTER of (string * command_node)
(* *)
| SHIFT_EDGE of (command_node * command_node * Label_cst.t) | SHIFT_EDGE of (command_node * command_node * Label_cst.t)
| SHIFT_IN of (command_node * command_node * Label_cst.t) | SHIFT_IN of (command_node * command_node * Label_cst.t)
| SHIFT_OUT of (command_node * command_node * Label_cst.t) | SHIFT_OUT of (command_node * command_node * Label_cst.t)
...@@ -172,18 +172,16 @@ module Command = struct ...@@ -172,18 +172,16 @@ module Command = struct
| H_SHIFT_OUT of (Gid.t * Gid.t) | H_SHIFT_OUT of (Gid.t * Gid.t)
let build ?domain ?param (kai, kei) table ast_command = let build ?domain ?param (kni, kei) table ast_command =
(* kai stands for "known act ident", kei for "known edge ident" *) (* kni stands for "known node idents", kei for "known edge idents" *)
let pid_of_act_id loc node_name =
try (* TODO: remove with activate *)
Pat (Pid.Pos (Id.build ~loc node_name table))
with _ -> New node_name in
let pid_of_node_id loc node_id = Pat (Pid.Pos (Id.build ~loc node_id table)) in let cn_of_node_id node_id =
match Id.build_opt node_id table with
| Some x -> Pat (Pid.Pos x)
| None -> New node_id in
let check_node_id loc node_id kai = let check_node_id loc node_id kni =
if not (List.mem node_id kai) if not (List.mem node_id kni)
then Error.build ~loc "Unbound node identifier \"%s\"" node_id in then Error.build ~loc "Unbound node identifier \"%s\"" node_id in
(* check that the edge_id is defined in the pattern *) (* check that the edge_id is defined in the pattern *)
...@@ -192,78 +190,78 @@ module Command = struct ...@@ -192,78 +190,78 @@ module Command = struct
then Error.build ~loc "Unbound edge identifier \"%s\"" edge_id in then Error.build ~loc "Unbound edge identifier \"%s\"" edge_id in
match ast_command with match ast_command with
| (Ast.Del_edge_expl (act_i, act_j, lab), loc) -> | (Ast.Del_edge_expl (node_i, node_j, lab), loc) ->
check_node_id loc act_i kai; check_node_id loc node_i kni;
check_node_id loc act_j kai; check_node_id loc node_j kni;
let edge = G_edge.make ~loc ?domain lab in let edge = G_edge.make ~loc ?domain lab in
((DEL_EDGE_EXPL (pid_of_act_id loc act_i, pid_of_act_id loc act_j, edge), loc), (kai, kei)) ((DEL_EDGE_EXPL (cn_of_node_id node_i, cn_of_node_id node_j, edge), loc), (kni, kei))
| (Ast.Del_edge_name id, loc) -> | (Ast.Del_edge_name id, loc) ->
check_edge loc id kei; check_edge loc id kei;
(DEL_EDGE_NAME id, loc), (kai, List_.rm id kei) (DEL_EDGE_NAME id, loc), (kni, List_.rm id kei)
| (Ast.Add_edge (act_i, act_j, lab), loc) -> | (Ast.Add_edge (node_i, node_j, lab), loc) ->
check_node_id loc act_i kai; check_node_id loc node_i kni;
check_node_id loc act_j kai; check_node_id loc node_j kni;
let edge = G_edge.make ~loc ?domain lab in let edge = G_edge.make ~loc ?domain lab in
((ADD_EDGE (pid_of_act_id loc act_i, pid_of_act_id loc act_j, edge), loc), (kai, kei)) ((ADD_EDGE (cn_of_node_id node_i, cn_of_node_id node_j, edge), loc), (kni, kei))
| (Ast.Add_edge_expl (act_i, act_j, name), loc) -> | (Ast.Add_edge_expl (node_i, node_j, name), loc) ->
check_node_id loc act_i kai; check_node_id loc node_i kni;
check_node_id loc act_j kai; check_node_id loc node_j kni;
((ADD_EDGE_EXPL (pid_of_act_id loc act_i, pid_of_act_id loc act_j, name), loc), (kai, kei)) ((ADD_EDGE_EXPL (cn_of_node_id node_i, cn_of_node_id node_j, name), loc), (kni, kei))
| (Ast.Shift_edge (act_i, act_j, label_cst), loc) -> | (Ast.Shift_edge (node_i, node_j, label_cst), loc) ->
check_node_id loc act_i kai; check_node_id loc node_i kni;
check_node_id loc act_j kai; check_node_id loc node_j kni;
((SHIFT_EDGE (pid_of_act_id loc act_i, pid_of_act_id loc act_j, Label_cst.build ~loc ?domain label_cst), loc), (kai, kei)) ((SHIFT_EDGE (cn_of_node_id node_i, cn_of_node_id node_j, Label_cst.build ~loc ?domain label_cst), loc), (kni, kei))
| (Ast.Shift_in (act_i, act_j, label_cst), loc) -> | (Ast.Shift_in (node_i, node_j, label_cst), loc) ->
check_node_id loc act_i kai; check_node_id loc node_i kni;
check_node_id loc act_j kai; check_node_id loc node_j kni;
((SHIFT_IN (pid_of_act_id loc act_i, pid_of_act_id loc act_j, Label_cst.build ?domain ~loc label_cst), loc), (kai, kei)) ((SHIFT_IN (cn_of_node_id node_i, cn_of_node_id node_j, Label_cst.build ?domain ~loc label_cst), loc), (kni, kei))
| (Ast.Shift_out (act_i, act_j, label_cst), loc) -> | (Ast.Shift_out (node_i, node_j, label_cst), loc) ->
check_node_id loc act_i kai; check_node_id loc node_i kni;
check_node_id loc act_j kai; check_node_id loc node_j kni;
((SHIFT_OUT (pid_of_act_id loc act_i, pid_of_act_id loc act_j, Label_cst.build ?domain ~loc label_cst), loc), (kai, kei)) ((SHIFT_OUT (cn_of_node_id node_i, cn_of_node_id node_j, Label_cst.build ?domain ~loc label_cst), loc), (kni, kei))
| (Ast.New_node new_id, loc) -> | (Ast.New_node new_id, loc) ->
if List.mem new_id kai if List.mem new_id kni
then Error.build ~loc "Node identifier \"%s\" is already used" new_id; then Error.build ~loc "Node identifier \"%s\" is already used" new_id;
(((NEW_NODE new_id), loc),(new_id::kai, kei)) (((NEW_NODE new_id), loc),(new_id::kni, kei))
| (Ast.New_before (new_id, old_id), loc) -> | (Ast.New_before (new_id, old_id), loc) ->
check_node_id loc old_id kai; check_node_id loc old_id kni;
if List.mem new_id kai if List.mem new_id kni
then Error.build ~loc "Node identifier \"%s\" is already used" new_id; then Error.build ~loc "Node identifier \"%s\" is already used" new_id;
((NEW_BEFORE (new_id,pid_of_act_id loc old_id), loc),(new_id::kai, kei)) ((NEW_BEFORE (new_id,cn_of_node_id old_id), loc),(new_id::kni, kei))
| (Ast.New_after (new_id, old_id), loc) -> | (Ast.New_after (new_id, old_id), loc) ->
check_node_id loc old_id kai; check_node_id loc old_id kni;
if List.mem new_id kai if List.mem new_id kni
then Error.build ~loc "Node identifier \"%s\" is already used" new_id; then Error.build ~loc "Node identifier \"%s\" is already used" new_id;
((NEW_AFTER (new_id,pid_of_act_id loc old_id), loc),(new_id::kai, kei)) ((NEW_AFTER (new_id,cn_of_node_id old_id), loc),(new_id::kni, kei))
| (Ast.Del_node act_n, loc) -> | (Ast.Del_node node_n, loc) ->
check_node_id loc act_n kai; check_node_id loc node_n kni;
((DEL_NODE (pid_of_act_id loc act_n), loc), (List_.rm act_n kai, kei)) ((DEL_NODE (cn_of_node_id node_n), loc), (List_.rm node_n kni, kei))
| (Ast.Del_feat (act_id, feat_name), loc) -> | (Ast.Del_feat (node_id, feat_name), loc) ->
if feat_name = "position" if feat_name = "position"
then Error.build ~loc "Illegal del_feat command: the 'position' feature cannot be deleted"; then Error.build ~loc "Illegal del_feat command: the 'position' feature cannot be deleted";
check_node_id loc act_id kai; check_node_id loc node_id kni;
Domain.check_feature_name ~loc ?domain feat_name; Domain.check_feature_name ~loc ?domain feat_name;
((DEL_FEAT (pid_of_act_id loc act_id, feat_name), loc), (kai, kei)) ((DEL_FEAT (cn_of_node_id node_id, feat_name), loc), (kni, kei))
| (Ast.Update_feat ((act_id, feat_name), ast_items), loc) -> | (Ast.Update_feat ((node_id, feat_name), ast_items), loc) ->
check_node_id loc act_id kai; check_node_id loc node_id kni;
let items = List.map let items = List.map
(function (function
| Ast.Qfn_item (node_id,feature_name) -> | Ast.Qfn_item (node_id,feature_name) ->
check_node_id loc node_id kai; check_node_id loc node_id kni;
Domain.check_feature_name ~loc ?domain feature_name; Domain.check_feature_name ~loc ?domain feature_name;
Feat (pid_of_node_id loc node_id, feature_name) Feat (cn_of_node_id node_id, feature_name)
| Ast.String_item s -> String s | Ast.String_item s -> String s
| Ast.Param_item var -> | Ast.Param_item var ->
match param with match param with
...@@ -281,6 +279,6 @@ module Command = struct ...@@ -281,6 +279,6 @@ module Command = struct
| [String s] -> Domain.check_feature ~loc ?domain feat_name s | [String s] -> Domain.check_feature ~loc ?domain feat_name s
| [Feat (_,fn)] -> () | [Feat (_,fn)] -> ()
| _ -> Error.build ~loc "[Update_feat] Only open features can be modified with the concat operator '+' but \"%s\" is not declared as an open feature" feat_name); | _ -> Error.build ~loc "[Update_feat] Only open features can be modified with the concat operator '+' but \"%s\" is not declared as an open feature" feat_name);
((UPDATE_FEAT (pid_of_act_id loc act_id, feat_name, items), loc), (kai, kei)) ((UPDATE_FEAT (cn_of_node_id node_id, feat_name, items), loc), (kni, kei))
end (* module Command *) end (* module Command *)
...@@ -464,21 +464,21 @@ module Rule = struct ...@@ -464,21 +464,21 @@ module Rule = struct
(* ====================================================================== *) (* ====================================================================== *)
let build_commands ?domain ?param pos pos_table ast_commands = let build_commands ?domain ?param pos pos_table ast_commands =
let known_act_ids = Array.to_list pos_table in let known_node_ids = Array.to_list pos_table in
let known_edge_ids = get_edge_ids pos in let known_edge_ids = get_edge_ids pos in
let rec loop (kai,kei) = function let rec loop (kni,kei) = function
| [] -> [] | [] -> []
| ast_command :: tail -> | ast_command :: tail ->
let (command, (new_kai, new_kei)) = let (command, (new_kni, new_kei)) =
Command.build Command.build
?domain ?domain
?param ?param
(kai,kei) (kni,kei)
pos_table pos_table
ast_command in ast_command in
command :: (loop (new_kai,new_kei) tail) in command :: (loop (new_kni,new_kei) tail) in
loop (known_act_ids, known_edge_ids) ast_commands loop (known_node_ids, known_edge_ids) ast_commands
(* ====================================================================== *) (* ====================================================================== *)
let parse_vars loc vars = let parse_vars loc vars =
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment