Skip to content
GitLab
Commit 8b3202b7 authored by Bruno Guillaume's avatar Bruno Guillaume
Browse files

TMP_activate command

parent 00d588ef
Hide whitespace changes
Inline Side-by-side
src/grew_command.ml
View file @ 8b3202b7
......@@ -20,9 +20,10 @@ 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 *)
| Act of Pid.t * string (* a node introduced by a activate *)
| New of string (* a node introduced by a new_neighbour *) (* TODO: remove *)
| Act of Pid.t * string (* a node introduced by an activate *)
(* [item] is a element of the RHS of an update_feat command *)
type item =
| Feat of (command_node * string)
| String of string
......@@ -37,29 +38,33 @@ module Command = struct
| ADD_EDGE of (command_node * command_node * G_edge.t)
| DEL_FEAT of (command_node * string)
| UPDATE_FEAT of (command_node * string * item list)
| NEW_NEIGHBOUR of (string * G_edge.t * Pid.t)
| NEW_NEIGHBOUR of (string * G_edge.t * Pid.t) (* TODO: remove *)
| 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)
| ACT_NODE of command_node
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.t
| H_DEL_EDGE_EXPL of (Gid.t * Gid.t *G_edge.t)
| H_DEL_EDGE_EXPL of (Gid.t * Gid.t * G_edge.t)
| H_DEL_EDGE_NAME of string
| 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_NEW_NEIGHBOUR of (string * G_edge.t * Gid.t) (* TODO: remove *)
| 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)
| H_ACT_NODE of (Gid.t * string)
let build ?param (kai, kei) table locals ast_command =
(* kai stands for "known act ident", kei for "known edge ident" *)
let pid_of_act_id loc = function
| (node_name, Some n) -> Act (Pid.Pos (Id.build ~loc node_name table), n)
......@@ -68,58 +73,61 @@ module Command = struct
Pat (Pid.Pos (Id.build ~loc node_name table))
with _ -> New node_name in
(* check that an act_id is well-defined earlier *)
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
(* check that the edge_id is defined in the pattern *)
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
match ast_command with
| (Ast.Del_edge_expl (act_i, act_j, lab), loc) ->
check_act_id loc act_i kai;
check_act_id loc act_j kai;
let edge = G_edge.make ~loc ~locals lab in
((DEL_EDGE_EXPL (pid_of_act_id loc act_i, pid_of_act_id loc act_j, edge), loc), (kai, kei))
check_act_id loc act_i kai;
check_act_id loc act_j kai;
let edge = G_edge.make ~loc ~locals lab in
((DEL_EDGE_EXPL (pid_of_act_id loc act_i, pid_of_act_id loc act_j, edge), loc), (kai, kei))
| (Ast.Del_edge_name id, loc) ->
check_edge loc id kei;
(DEL_EDGE_NAME id, loc), (kai, List_.rm id kei)
check_edge loc id kei;
(DEL_EDGE_NAME id, loc), (kai, List_.rm id kei)
| (Ast.Add_edge (act_i, act_j, lab), loc) ->
check_act_id loc act_i kai;
check_act_id loc act_j kai;
let edge = G_edge.make ~loc ~locals lab in
((ADD_EDGE (pid_of_act_id loc act_i, pid_of_act_id loc act_j, edge), loc), (kai, kei))
check_act_id loc act_i kai;
check_act_id loc act_j kai;
let edge = G_edge.make ~loc ~locals lab in
((ADD_EDGE (pid_of_act_id loc act_i, pid_of_act_id loc 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 loc act_i, pid_of_act_id loc act_j), loc), (kai, kei))
check_act_id loc act_i kai;
check_act_id loc act_j kai;
((SHIFT_EDGE (pid_of_act_id loc act_i, pid_of_act_id loc 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 loc act_i, pid_of_act_id loc act_j), loc), (kai, kei))
check_act_id loc act_i kai;
check_act_id loc act_j kai;
((SHIFT_IN (pid_of_act_id loc act_i, pid_of_act_id loc 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 loc act_i, pid_of_act_id loc act_j), loc), (kai, kei))
check_act_id loc act_i kai;
check_act_id loc act_j kai;
((SHIFT_OUT (pid_of_act_id loc act_i, pid_of_act_id loc 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 loc act_i, pid_of_act_id loc act_j), loc), (List_.rm act_i kai, kei))
check_act_id loc act_i kai;
check_act_id loc act_j kai;
((MERGE_NODE (pid_of_act_id loc act_i, pid_of_act_id loc 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;
let edge = G_edge.make ~loc ~locals label in
begin
try
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;
let edge = G_edge.make ~loc ~locals label in
begin
try
(
(NEW_NEIGHBOUR
(new_id,
......@@ -128,43 +136,48 @@ module Command = struct
), loc),
((new_id, None)::kai, kei)
)
with Not_found ->
Log.fcritical "[GRS] tries to build a command New_neighbour (%s) on node %s which is not in the pattern %s"
(G_edge.to_string edge)
(fst ancestor)
(Loc.to_string loc)
end
with not_found ->
Log.fcritical "[GRS] tries to build a command New_neighbour (%s) on node %s which is not in the pattern %s"
(G_edge.to_string edge)
(fst ancestor)
(Loc.to_string loc)
end
| (Ast.Activate (_,None), loc) ->
Error.build ~loc "Cannot activate a pattern node"
| (Ast.Activate n, loc) -> failwith "Not implemented"
| (Ast.Activate act_n, loc) ->
(* TODO: add a check on source node *)
((ACT_NODE (pid_of_act_id loc act_n), loc), (act_n :: kai, kei))
| (Ast.Del_node act_n, loc) ->
check_act_id loc act_n kai;
((DEL_NODE (pid_of_act_id loc act_n), loc), (List_.rm act_n kai, kei))
check_act_id loc act_n kai;
((DEL_NODE (pid_of_act_id loc act_n), loc), (List_.rm act_n kai, kei))
| (Ast.Del_feat (act_id, feat_name), loc) ->
if feat_name = "position"
then Error.build ~loc "Illegal del_feat command: the 'position' feature cannot be deleted";
check_act_id loc act_id kai;
((DEL_FEAT (pid_of_act_id loc act_id, feat_name), loc), (kai, kei))
if feat_name = "position"
then Error.build ~loc "Illegal del_feat command: the 'position' feature cannot be deleted";
check_act_id loc act_id kai;
((DEL_FEAT (pid_of_act_id loc act_id, feat_name), loc), (kai, kei))
| (Ast.Update_feat ((act_id, feat_name), ast_items), loc) ->
check_act_id loc act_id kai;
let items = List.map
(function
(* 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 loc act_id, feature_name)
| 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_act_id loc act_id, feat_name, items), loc), (kai, kei))
check_act_id loc act_id kai;
let items = List.map
(function
(* 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 loc act_id, feature_name)
| 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_act_id loc act_id, feat_name, items), loc), (kai, kei))
end (* module Command *)
src/grew_command.mli
View file @ 8b3202b7
......@@ -15,8 +15,8 @@ open Grew_edge
(* ==================================================================================================== *)
module Command : sig
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 *)
| 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 *)
type item =
......@@ -37,8 +37,9 @@ module Command : sig
| SHIFT_IN of (command_node * command_node)
| SHIFT_OUT of (command_node * command_node)
| MERGE_NODE of (command_node * command_node)
| ACT_NODE of command_node
type t = (p * Loc.t)
type h =
| H_DEL_NODE of Gid.t
......@@ -52,6 +53,7 @@ module Command : sig
| H_SHIFT_IN of (Gid.t * Gid.t)
| H_SHIFT_OUT of (Gid.t * Gid.t)
| H_MERGE_NODE of (Gid.t * Gid.t)
| H_ACT_NODE of (Gid.t * string)
val build:
?param: (string list * string list) ->
......
src/grew_graph.ml
View file @ 8b3202b7
......@@ -449,6 +449,19 @@ module G_graph = struct
) graph.map Gid_map.empty
}
(* -------------------------------------------------------------------------------- *)
let activate loc node_id new_name graph =
let index = match node_id with
| Gid.Old id -> Gid.Act (id, new_name)
| _ -> Error.run ~loc "[Graph.activate] is possible only from a \"ground\" node" in
if Gid_map.mem index graph.map
then Error.run ~loc "[Graph.activate] try to activate twice the \"same\" node (with new_name '%s')" new_name;
let node = Gid_map.find node_id graph.map in
let new_map = Gid_map.add index (G_node.build_new node) graph.map in
(index, {graph with map = new_map})
(* -------------------------------------------------------------------------------- *)
let add_neighbour loc graph node_id label =
let index = match node_id with
......
src/grew_graph.mli
View file @ 8b3202b7
......@@ -50,7 +50,7 @@ module P_graph: sig
type extension = {
ext_map: P_node.t Pid_map.t; (* node description for new nodes and for edge "Old -> New" *)
old_map: P_node.t Pid_map.t; (* a partial map for new constraints on old nodes "Old [...]" *)
old_map: P_node.t Pid_map.t; (* a partial map for new constraints on old nodes "Old [...]" *)
}
(* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
......@@ -137,6 +137,7 @@ module G_graph: sig
val del_node: t -> Gid.t -> t
val add_neighbour: Loc.t -> t -> Gid.t -> G_edge.t -> (Gid.t * t)
val activate: Loc.t -> Gid.t -> string -> t -> (Gid.t * t)
val merge_node: Loc.t -> t -> Gid.t -> Gid.t -> t option
......
src/grew_node.ml
View file @ 8b3202b7
......@@ -82,6 +82,8 @@ module G_node = struct
let build_neighbour t = { empty with position = (get_position t) +. 0.01 }
let build_new t = { empty with position = (get_position t) +. 0.01 }
let position_comp n1 n2 = Pervasives.compare n1.position n2.position
let rename mapping n = {n with next = Massoc_gid.rename mapping n.next}
......
src/grew_node.mli
View file @ 8b3202b7
......@@ -53,6 +53,7 @@ module G_node: sig
val get_annot_info: t -> string option
val build_neighbour: t -> t
val build_new: t -> t
val rename: (Gid.t * Gid.t) list -> t -> t
end
......
src/grew_rule.ml
View file @ 8b3202b7
......@@ -352,7 +352,7 @@ module Rule = struct
G_deco.edges = List.fold_left (fun acc (_,edge) -> edge::acc) matching.a_match matching.e_match;
}
let find cnode ?loc (matching, created_nodes) =
let find cnode ?loc (matching, (created_nodes,activated_nodes)) =
match cnode with
| Command.Pat pid ->
(try Pid_map.find pid matching.n_match
......@@ -360,7 +360,10 @@ module Rule = struct
| Command.New name ->
(try List.assoc name created_nodes
with Not_found -> Error.run ?loc "Identifier '%s' not found" name)
| Command.Act _ -> Log.critical "TODO: not yet implemented"
| Command.Act (pid, new_name) ->
(try List.assoc (pid, new_name) activated_nodes
with Not_found -> Error.run ?loc "Activated identifier with suffix '%s' not found" new_name)
let down_deco (matching,created_nodes) commands =
......@@ -566,8 +569,8 @@ module Rule = struct
exception Command_execution_fail
(** [apply_command instance matching created_nodes command] returns [(new_instance, new_created_nodes)] *)
let apply_command (command,loc) instance matching created_nodes =
let node_find cnode = find ~loc cnode (matching, created_nodes) in
let apply_command (command,loc) instance matching (created_nodes, (activated_nodes:((Pid.t * string) * Gid.t) list)) =
let node_find cnode = find ~loc cnode (matching, (created_nodes, activated_nodes)) in
match command with
| Command.ADD_EDGE (src_cn,tar_cn,edge) ->
......@@ -581,7 +584,7 @@ module Rule = struct
Instance.graph = new_graph;
history = List_.sort_insert (Command.H_ADD_EDGE (src_gid,tar_gid,edge)) instance.Instance.history
},
created_nodes
(created_nodes, activated_nodes)
)
| None ->
Error.run "ADD_EDGE: the edge '%s' already exists %s" (G_edge.to_string edge) (Loc.to_string loc)
......@@ -595,7 +598,7 @@ module Rule = struct
Instance.graph = G_graph.del_edge loc instance.Instance.graph src_gid edge tar_gid;
history = List_.sort_insert (Command.H_DEL_EDGE_EXPL (src_gid,tar_gid,edge)) instance.Instance.history
},
created_nodes
(created_nodes, activated_nodes)
)
| Command.DEL_EDGE_NAME edge_ident ->
......@@ -607,7 +610,7 @@ module Rule = struct
Instance.graph = G_graph.del_edge ~edge_ident loc instance.Instance.graph src_gid edge tar_gid;
history = List_.sort_insert (Command.H_DEL_EDGE_EXPL (src_gid,tar_gid,edge)) instance.Instance.history
},
created_nodes
(created_nodes, activated_nodes)
)
| Command.DEL_NODE node_cn ->
......@@ -617,7 +620,7 @@ module Rule = struct
Instance.graph = G_graph.del_node instance.Instance.graph node_gid;
history = List_.sort_insert (Command.H_DEL_NODE node_gid) instance.Instance.history
},
created_nodes
(created_nodes, activated_nodes)
)
| Command.MERGE_NODE (src_cn, tar_cn) ->
......@@ -630,7 +633,7 @@ module Rule = struct
Instance.graph = new_graph;
history = List_.sort_insert (Command.H_MERGE_NODE (src_gid,tar_gid)) instance.Instance.history
},
created_nodes
(created_nodes, activated_nodes)
)
| None -> raise Command_execution_fail
)
......@@ -658,7 +661,7 @@ module Rule = struct
Instance.graph = new_graph;
history = List_.sort_insert (Command.H_UPDATE_FEAT (tar_gid,tar_feat_name,new_feature_value)) instance.Instance.history
},
created_nodes
(created_nodes, activated_nodes)
)
| Command.DEL_FEAT (tar_cn,feat_name) ->
......@@ -668,7 +671,7 @@ module Rule = struct
Instance.graph = G_graph.del_feat instance.Instance.graph tar_gid feat_name;
history = List_.sort_insert (Command.H_DEL_FEAT (tar_gid,feat_name)) instance.Instance.history
},
created_nodes
(created_nodes, activated_nodes)
)
| Command.NEW_NEIGHBOUR (created_name,edge,base_pid) ->
......@@ -680,7 +683,18 @@ module Rule = struct
history = List_.sort_insert (Command.H_NEW_NEIGHBOUR (created_name,edge,new_gid)) instance.Instance.history;
activated_node = new_gid :: instance.Instance.activated_node;
},
(created_name,new_gid) :: created_nodes
((created_name,new_gid) :: created_nodes, activated_nodes)
)
| Command.ACT_NODE (Command.Act (pid, new_name)) ->
let node_gid = node_find (Command.Pat(pid)) in
let (new_gid, new_graph) = G_graph.activate loc node_gid new_name instance.Instance.graph in
(
{instance with
Instance.graph = new_graph;
history = List_.sort_insert (Command.H_ACT_NODE (node_gid,new_name)) instance.Instance.history
},
(created_nodes, ((pid, new_name), new_gid) :: activated_nodes)
)
| Command.SHIFT_IN (src_cn,tar_cn) ->
......@@ -691,7 +705,7 @@ module Rule = struct
Instance.graph = G_graph.shift_in loc instance.Instance.graph src_gid tar_gid;
history = List_.sort_insert (Command.H_SHIFT_IN (src_gid,tar_gid)) instance.Instance.history
},
created_nodes
(created_nodes, activated_nodes)
)
| Command.SHIFT_OUT (src_cn,tar_cn) ->
......@@ -702,7 +716,7 @@ module Rule = struct
Instance.graph = G_graph.shift_out loc instance.Instance.graph src_gid tar_gid;
history = List_.sort_insert (Command.H_SHIFT_OUT (src_gid,tar_gid)) instance.Instance.history
},
created_nodes
(created_nodes, activated_nodes)
)
| Command.SHIFT_EDGE (src_cn,tar_cn) ->
......@@ -713,7 +727,7 @@ module Rule = struct
Instance.graph = G_graph.shift_edges loc instance.Instance.graph src_gid tar_gid;
history = List_.sort_insert (Command.H_SHIFT_EDGE (src_gid,tar_gid)) instance.Instance.history
},
created_nodes
(created_nodes, activated_nodes)
)
(** [apply_rule instance matching rule] returns a new instance after the application of the rule
......@@ -735,7 +749,7 @@ module Rule = struct
(fun (instance, created_nodes) command ->
apply_command command instance matching created_nodes
)
(instance, [])
(instance, ([],[]))
rule.commands in
let rule_app = {
......
src/libgrew_utils.ml
View file @ 8b3202b7
......@@ -169,17 +169,27 @@ module Gid = struct
type t =
| Old of int
| New of (int * int) (* identifier for "created nodes" *)
| Act of (int * string) (* identifier for "activated nodes" *)
(* a compare function which ensures that new nodes are at the "end" of the graph *)
let compare t1 t2 = match (t1,t2) with
| Old o1, Old o2 -> Pervasives.compare o1 o2
| Old _ , New _ -> -1
| New _, Old _ -> 1
| Old o1, Old o2 -> Pervasives.compare o1 o2
| New n1, New n2 -> Pervasives.compare n1 n2
| Old _ , Act _ -> -1
| Act _, Old _ -> 1
| Act n1, Act n2 -> Pervasives.compare n1 n2
| Act _ , New _ -> -1
| New _, Act _ -> 1
let to_string = function
| Old i -> sprintf "%d" i
| New (i,j) -> sprintf"%d__%d" i j
| Act (i,n) -> sprintf"%d#%s" i n
end (* module Gid *)
(* ================================================================================ *)
......
src/libgrew_utils.mli
View file @ 8b3202b7
......@@ -83,6 +83,7 @@ module Gid : sig
type t =
| Old of int
| New of (int * int) (* identifier for "created nodes" *)
| Act of (int * string) (* identifier for "activated nodes" *)
val compare: t -> t -> int
......
src/parser/lexer.mll
View file @ 8b3202b7
......@@ -22,6 +22,7 @@
(* a general notion of "ident" is needed to cover all usages:
with or without '#', with several '.' (separator for feature names and usual symbol for labels...) *)
let parse_complex_ident string =
printf "--parse_complex_ident-->%s<--\n%!" string;
match Str.split (Str.regexp "#") string with
| [x] -> Ast.No_sharp x
| [x;y] -> Ast.Sharp (x,y)
......@@ -118,6 +119,7 @@ and global = parse
| "del_node" { DEL_NODE }
| "add_node" { ADD_NODE }
| "del_feat" { DEL_FEAT }
| "activate" { ACTIVATE }
| "module" { MODULE }
| "confluent" { CONFLUENT }
......
Supports Markdown
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