Skip to content

GitLab

L
libcaml-grew
Commit e86ca5d2 authored by Bruno Guillaume's avatar Bruno Guillaume
Browse files
Options

code rewriting

parent 40b093d0
Hide whitespace changes
Inline Side-by-side
Showing with 63 additions and 65 deletions
src/grew_command.ml
View file @ e86ca5d2
......@@ -20,9 +20,9 @@ open Grew_fs
(* ================================================================================ *)
module Command = struct
type command_node = (* 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 *) (* TODO: remove *)
type command_node = (* a command node is either: *)
| Pat of Pid.t (* a node identified in the pattern *)
| New of string (* a node introduced by a add_node *)
let command_node_to_json = function
| Pat pid -> `String (Pid.to_string pid)
......@@ -55,11 +55,11 @@ module Command = struct
| ADD_EDGE_EXPL of (command_node * command_node * string)
| DEL_FEAT of (command_node * string)
| UPDATE_FEAT of (command_node * string * item list)
(* *)
| NEW_NODE of string
| NEW_BEFORE of (string * command_node)
| NEW_AFTER of (string * command_node)
(* *)
| SHIFT_EDGE 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)
......@@ -172,18 +172,16 @@ module Command = struct
| H_SHIFT_OUT of (Gid.t * Gid.t)
let build ?domain ?param (kai, kei) table ast_command =
(* kai stands for "known act ident", kei for "known edge ident" *)
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 build ?domain ?param (kni, kei) table ast_command =
(* kni stands for "known node idents", kei for "known edge idents" *)
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 =
if not (List.mem node_id kai)
let check_node_id loc node_id kni =
if not (List.mem node_id kni)
then Error.build ~loc "Unbound node identifier \"%s\"" node_id in
(* check that the edge_id is defined in the pattern *)
......@@ -192,78 +190,78 @@ module Command = struct
then Error.build ~loc "Unbound edge identifier \"%s\"" edge_id in
match ast_command with
| (Ast.Del_edge_expl (act_i, act_j, lab), loc) ->
check_node_id loc act_i kai;
check_node_id loc act_j kai;
| (Ast.Del_edge_expl (node_i, node_j, lab), loc) ->
check_node_id loc node_i kni;
check_node_id loc node_j kni;
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) ->
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) ->
check_node_id loc act_i kai;
check_node_id loc act_j kai;
| (Ast.Add_edge (node_i, node_j, lab), loc) ->
check_node_id loc node_i kni;
check_node_id loc node_j kni;
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) ->
check_node_id loc act_i kai;
check_node_id loc act_j kai;
((ADD_EDGE_EXPL (pid_of_act_id loc act_i, pid_of_act_id loc act_j, name), loc), (kai, kei))
| (Ast.Add_edge_expl (node_i, node_j, name), loc) ->
check_node_id loc node_i kni;
check_node_id loc node_j kni;
((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) ->
check_node_id loc act_i kai;
check_node_id loc act_j kai;
((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))
| (Ast.Shift_edge (node_i, node_j, label_cst), loc) ->
check_node_id loc node_i kni;
check_node_id loc node_j kni;
((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) ->
check_node_id loc act_i kai;
check_node_id loc act_j kai;
((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))
| (Ast.Shift_in (node_i, node_j, label_cst), loc) ->
check_node_id loc node_i kni;
check_node_id loc node_j kni;
((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) ->
check_node_id loc act_i kai;
check_node_id loc act_j kai;
((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))
| (Ast.Shift_out (node_i, node_j, label_cst), loc) ->
check_node_id loc node_i kni;
check_node_id loc node_j kni;
((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) ->
if List.mem new_id kai
if List.mem new_id kni
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) ->
check_node_id loc old_id kai;
if List.mem new_id kai
check_node_id loc old_id kni;
if List.mem new_id kni
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) ->
check_node_id loc old_id kai;
if List.mem new_id kai
check_node_id loc old_id kni;
if List.mem new_id kni
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) ->
check_node_id loc act_n kai;
((DEL_NODE (pid_of_act_id loc act_n), loc), (List_.rm act_n kai, kei))
| (Ast.Del_node node_n, loc) ->
check_node_id loc node_n kni;
((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"
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;
((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) ->
check_node_id loc act_id kai;
| (Ast.Update_feat ((node_id, feat_name), ast_items), loc) ->
check_node_id loc node_id kni;
let items = List.map
(function
| 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;
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.Param_item var ->
match param with
......@@ -281,6 +279,6 @@ module Command = struct
| [String s] -> Domain.check_feature ~loc ?domain feat_name s
| [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);
((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 *)
src/grew_rule.ml
View file @ e86ca5d2
......@@ -464,21 +464,21 @@ module Rule = struct
(* ====================================================================== *)
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 rec loop (kai,kei) = function
let rec loop (kni,kei) = function
| [] -> []
| ast_command :: tail ->
let (command, (new_kai, new_kei)) =
let (command, (new_kni, new_kei)) =
Command.build
?domain
?param
(kai,kei)
(kni,kei)
pos_table
ast_command in
command :: (loop (new_kai,new_kei) tail) in
loop (known_act_ids, known_edge_ids) ast_commands
command :: (loop (new_kni,new_kei) tail) in
loop (known_node_ids, known_edge_ids) ast_commands
(* ====================================================================== *)
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