Commit a1221055 authored by bguillaum's avatar bguillaum

add module Grew_types.Label_cst

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@8631 7838e531-6607-4d57-9587-6c381814729c
parent 81b2f31f
......@@ -121,6 +121,9 @@ module Ast = struct
type edge_label = string
(* (list of edge_label separated by '|', bool true iff it is a negative constraint) *)
type edge_label_cst = edge_label list * bool
type u_edge = {
edge_id: Id.name option;
src: Id.name;
......@@ -175,9 +178,9 @@ module Ast = struct
| Add_edge of (command_node_ident * command_node_ident * edge_label)
(* 4 args: source, target, labels, flag true iff negative cst *)
| Shift_in of (command_node_ident * command_node_ident * edge_label list * bool)
| Shift_out of (command_node_ident * command_node_ident * edge_label list * bool)
| Shift_edge of (command_node_ident * command_node_ident * edge_label list * bool)
| Shift_in of (command_node_ident * command_node_ident * edge_label_cst)
| Shift_out of (command_node_ident * command_node_ident * edge_label_cst)
| Shift_edge of (command_node_ident * command_node_ident * edge_label_cst)
| Merge_node of (command_node_ident * command_node_ident)
| New_neighbour of (Id.name * command_node_ident * edge_label)
......
......@@ -76,6 +76,9 @@ module Ast : sig
type edge_label = string (* p_obj.agt:suj *)
(* (list of edge_label separated by '|', bool true iff it is a negative constraint) *)
type edge_label_cst = edge_label list * bool
type u_edge = {
edge_id: Id.name option;
src: Id.name;
......@@ -120,9 +123,9 @@ module Ast : sig
| Add_edge of (command_node_ident * command_node_ident * edge_label)
(* 4 args: source, target, labels, flag true iff negative cst *)
| Shift_in of (command_node_ident * command_node_ident * edge_label list * bool)
| Shift_out of (command_node_ident * command_node_ident * edge_label list * bool)
| Shift_edge of (command_node_ident * command_node_ident * edge_label list * bool)
| Shift_in of (command_node_ident * command_node_ident * edge_label_cst)
| Shift_out of (command_node_ident * command_node_ident * edge_label_cst)
| Shift_edge of (command_node_ident * command_node_ident * edge_label_cst)
| Merge_node of (command_node_ident * command_node_ident)
| New_neighbour of (Id.name * command_node_ident * edge_label)
......
......@@ -41,9 +41,9 @@ module Command = struct
| DEL_FEAT of (command_node * string)
| UPDATE_FEAT of (command_node * string * item list)
| NEW_NEIGHBOUR of (string * G_edge.t * Pid.t) (* TODO: remove *)
| SHIFT_EDGE of (command_node * command_node * Label.t list * bool)
| SHIFT_IN of (command_node * command_node * Label.t list * bool)
| SHIFT_OUT of (command_node * command_node * Label.t list * bool)
| 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)
| MERGE_NODE of (command_node * command_node)
| ACT_NODE of command_node
......@@ -108,20 +108,20 @@ module Command = struct
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, labels, neg), loc) ->
| (Ast.Shift_edge (act_i, act_j, label_cst), 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, List.map (Label.from_string ~loc) labels, neg), loc), (kai, kei))
((SHIFT_EDGE (pid_of_act_id loc act_i, pid_of_act_id loc act_j, Label_cst.build ~loc ~locals label_cst), loc), (kai, kei))
| (Ast.Shift_in (act_i, act_j, labels, neg), loc) ->
| (Ast.Shift_in (act_i, act_j, label_cst), 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, List.map (Label.from_string ~loc) labels, neg), loc), (kai, kei))
((SHIFT_IN (pid_of_act_id loc act_i, pid_of_act_id loc act_j, Label_cst.build ~loc ~locals label_cst), loc), (kai, kei))
| (Ast.Shift_out (act_i, act_j, labels, neg), loc) ->
| (Ast.Shift_out (act_i, act_j, label_cst), 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, List.map (Label.from_string ~loc) labels, neg), loc), (kai, kei))
((SHIFT_OUT (pid_of_act_id loc act_i, pid_of_act_id loc act_j, Label_cst.build ~loc ~locals label_cst), loc), (kai, kei))
| (Ast.Merge_node (act_i, act_j), loc) ->
check_act_id loc act_i kai;
......
......@@ -35,9 +35,9 @@ module Command : sig
| DEL_FEAT of (command_node * string)
| UPDATE_FEAT of (command_node * string * item list)
| NEW_NEIGHBOUR of (string * G_edge.t * Pid.t)
| SHIFT_EDGE of (command_node * command_node * Label.t list * bool)
| SHIFT_IN of (command_node * command_node * Label.t list * bool)
| SHIFT_OUT of (command_node * command_node * Label.t list * bool)
| 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)
| MERGE_NODE of (command_node * command_node)
| ACT_NODE of command_node
......
......@@ -475,14 +475,9 @@ module G_graph = struct
| Some g -> (index, {graph with map = g})
| None -> Log.bug "[Graph.add_neighbour] add_edge must not fail"; exit 1
let match_ edge (labels,neg) =
(not neg && Label.match_list labels edge) || (neg && not (Label.match_list labels edge))
(* -------------------------------------------------------------------------------- *)
(* move out-edges (which respect cst [labels,neg]) from id_src are moved to out-edges out off node id_tar *)
let shift_out loc src_gid tar_gid (labels,neg) graph =
let shift_out loc src_gid tar_gid label_cst graph =
let src_node = Gid_map.find src_gid graph.map in
let tar_node = Gid_map.find tar_gid graph.map in
......@@ -493,14 +488,14 @@ module G_graph = struct
let src_tar_edges = Massoc_gid.assoc tar_gid src_next in
let _ =
try
let loop_edge = List.find (fun edge -> match_ edge (labels,neg)) src_tar_edges in
let loop_edge = List.find (fun edge -> Label_cst.match_ edge label_cst) src_tar_edges in
Error.run ~loc "The shfit_out command tries to build a loop (with label %s)" (Label.to_string loop_edge)
with Not_found -> () in
let (new_src_next,new_tar_next) =
Massoc_gid.fold
(fun (acc_src_next,acc_tar_next) next_gid edge ->
if match_ edge (labels,neg)
if Label_cst.match_ edge label_cst
then
match Massoc_gid.add next_gid edge acc_tar_next with
| Some new_acc_tar_next -> (Massoc_gid.remove next_gid edge acc_src_next, new_acc_tar_next)
......@@ -517,16 +512,15 @@ module G_graph = struct
}
(* -------------------------------------------------------------------------------- *)
let shift_in loc src_gid tar_gid (labels,neg) graph =
let shift_in loc src_gid tar_gid label_cst graph =
let tar_node = Gid_map.find tar_gid graph.map in
let tar_next = G_node.get_next tar_node in
(* Error if a loop is created by the shift_in *)
let tar_src_edges = Massoc_gid.assoc src_gid tar_next in
let _ =
try
let loop_edge = List.find (fun edge -> match_ edge (labels,neg)) tar_src_edges in
let loop_edge = List.find (fun edge -> Label_cst.match_ edge label_cst) tar_src_edges in
Error.run ~loc "The [shift_in] command tries to build a loop (with label \"%s\")" (Label.to_string loop_edge)
with Not_found -> () in
......@@ -541,7 +535,7 @@ module G_graph = struct
let (new_node_src_edges, new_node_tar_edges) =
List.fold_left
(fun (acc_node_src_edges,acc_node_tar_edges) edge ->
if match_ edge (labels,neg)
if Label_cst.match_ edge label_cst
then
match List_.usort_insert edge acc_node_tar_edges with
| None -> Error.run ~loc "The [shift_in] command tries to build a duplicate edge (with label \"%s\")" (Label.to_string edge)
......@@ -558,14 +552,14 @@ module G_graph = struct
}
(* -------------------------------------------------------------------------------- *)
let shift_edges loc src_gid tar_gid (labels,neg) graph =
let shift_edges loc src_gid tar_gid label_cst graph =
graph
|> (shift_in loc src_gid tar_gid (labels,neg))
|> (shift_out loc src_gid tar_gid (labels,neg))
|> (shift_in loc src_gid tar_gid label_cst)
|> (shift_out loc src_gid tar_gid label_cst)
(* -------------------------------------------------------------------------------- *)
let merge_node loc graph src_gid tar_gid =
let se_graph = shift_edges loc src_gid tar_gid ([],true) graph in
let se_graph = shift_edges loc src_gid tar_gid Label_cst.all graph in
let src_node = Gid_map.find src_gid se_graph.map in
let tar_node = Gid_map.find tar_gid se_graph.map in
......
......@@ -133,13 +133,13 @@ module G_graph: sig
val merge_node: Loc.t -> t -> Gid.t -> Gid.t -> t option
(** move all in arcs to id_src are moved to in arcs on node id_tar from graph, with all its incoming edges *)
val shift_in: Loc.t -> Gid.t -> Gid.t -> (Label.t list * bool) -> t -> t
val shift_in: Loc.t -> Gid.t -> Gid.t -> Label_cst.t -> t -> t
(** move all out-edges from id_src are moved to out-edges out off node id_tar *)
val shift_out: Loc.t -> Gid.t -> Gid.t -> (Label.t list * bool) -> t -> t
val shift_out: Loc.t -> Gid.t -> Gid.t -> Label_cst.t -> t -> t
(** move all incident arcs from/to id_src are moved to incident arcs on node id_tar from graph, with all its incoming and outcoming edges *)
val shift_edges: Loc.t -> Gid.t -> Gid.t -> (Label.t list * bool) -> t -> t
val shift_edges: Loc.t -> Gid.t -> Gid.t -> Label_cst.t -> t -> t
(** [update_feat tar_id tar_feat_name concat_items] sets the feature of the node [tar_id]
with feature name [tar_feat_name] to be the contatenation of values described by the [concat_items].
......
......@@ -56,25 +56,25 @@ module Html_doc = struct
| Ast.Add_edge (n1,n2,label) ->
bprintf buff "add_edge %s -[%s]-> %s" (Ast.dump_command_node_ident n1) label (Ast.dump_command_node_ident n2)
| Ast.Shift_in (n1,n2,[],true) ->
| Ast.Shift_in (n1,n2,([],true)) ->
bprintf buff "shift_in %s ==> %s" (Ast.dump_command_node_ident n1) (Ast.dump_command_node_ident n2)
| Ast.Shift_in (n1,n2,labels,false) ->
| Ast.Shift_in (n1,n2,(labels,false)) ->
bprintf buff "shift_in %s =[%s]=> %s" (Ast.dump_command_node_ident n1) (Ast.dump_command_node_ident n2) (List_.to_string (fun x->x) "|" labels)
| Ast.Shift_in (n1,n2,labels,true) ->
| Ast.Shift_in (n1,n2,(labels,true)) ->
bprintf buff "shift_in %s =[^%s]=> %s" (Ast.dump_command_node_ident n1) (Ast.dump_command_node_ident n2) (List_.to_string (fun x->x) "|" labels)
| Ast.Shift_out (n1,n2,[],true) ->
| Ast.Shift_out (n1,n2,([],true)) ->
bprintf buff "shift_out %s ==> %s" (Ast.dump_command_node_ident n1) (Ast.dump_command_node_ident n2)
| Ast.Shift_out (n1,n2,labels,false) ->
| Ast.Shift_out (n1,n2,(labels,false)) ->
bprintf buff "shift_out %s =[%s]=> %s" (Ast.dump_command_node_ident n1) (Ast.dump_command_node_ident n2) (List_.to_string (fun x->x) "|" labels)
| Ast.Shift_out (n1,n2,labels,true) ->
| Ast.Shift_out (n1,n2,(labels,true)) ->
bprintf buff "shift_out %s =[^%s]=> %s" (Ast.dump_command_node_ident n1) (Ast.dump_command_node_ident n2) (List_.to_string (fun x->x) "|" labels)
| Ast.Shift_edge (n1,n2,[],true) ->
| Ast.Shift_edge (n1,n2,([],true)) ->
bprintf buff "shift %s ==> %s" (Ast.dump_command_node_ident n1) (Ast.dump_command_node_ident n2)
| Ast.Shift_edge (n1,n2,labels,false) ->
| Ast.Shift_edge (n1,n2,(labels,false)) ->
bprintf buff "shift %s =[%s]=> %s" (Ast.dump_command_node_ident n1) (Ast.dump_command_node_ident n2) (List_.to_string (fun x->x) "|" labels)
| Ast.Shift_edge (n1,n2,labels,true) ->
| Ast.Shift_edge (n1,n2,(labels,true)) ->
bprintf buff "shift %s =[^%s]=> %s" (Ast.dump_command_node_ident n1) (Ast.dump_command_node_ident n2) (List_.to_string (fun x->x) "|" labels)
| Ast.Merge_node (n1,n2) -> bprintf buff "merge %s ==> %s" (Ast.dump_command_node_ident n1) (Ast.dump_command_node_ident n2)
......
......@@ -728,34 +728,34 @@ module Rule = struct
)
| Command.ACT_NODE _ -> Error.bug "Try to activate a node without suffix" (Loc.to_string loc)
| Command.SHIFT_IN (src_cn,tar_cn,labels,neg) ->
| Command.SHIFT_IN (src_cn,tar_cn,label_cst) ->
let src_gid = node_find src_cn in
let tar_gid = node_find tar_cn in
(
{instance with
Instance.graph = G_graph.shift_in loc src_gid tar_gid (labels,neg) instance.Instance.graph;
Instance.graph = G_graph.shift_in loc src_gid tar_gid label_cst instance.Instance.graph;
history = List_.sort_insert (Command.H_SHIFT_IN (src_gid,tar_gid)) instance.Instance.history
},
(created_nodes, activated_nodes)
)
| Command.SHIFT_OUT (src_cn,tar_cn,labels,neg) ->
| Command.SHIFT_OUT (src_cn,tar_cn,label_cst) ->
let src_gid = node_find src_cn in
let tar_gid = node_find tar_cn in
(
{instance with
Instance.graph = G_graph.shift_out loc src_gid tar_gid (labels,neg) instance.Instance.graph;
Instance.graph = G_graph.shift_out loc src_gid tar_gid label_cst instance.Instance.graph;
history = List_.sort_insert (Command.H_SHIFT_OUT (src_gid,tar_gid)) instance.Instance.history
},
(created_nodes, activated_nodes)
)
| Command.SHIFT_EDGE (src_cn,tar_cn,labels,neg) ->
| Command.SHIFT_EDGE (src_cn,tar_cn,label_cst) ->
let src_gid = node_find src_cn in
let tar_gid = node_find tar_cn in
(
{instance with
Instance.graph = G_graph.shift_edges loc src_gid tar_gid (labels,neg) instance.Instance.graph;
Instance.graph = G_graph.shift_edges loc src_gid tar_gid label_cst instance.Instance.graph;
history = List_.sort_insert (Command.H_SHIFT_EDGE (src_gid,tar_gid)) instance.Instance.history
},
(created_nodes, activated_nodes)
......
......@@ -227,6 +227,27 @@ module Label = struct
with Not_found -> Error.build "[Label.from_string] unknown edge label '%s'" string
end (* module Label *)
(* ================================================================================ *)
(** The module [Label_cst] defines contraints on label edges *)
module Label_cst = struct
type t =
| Pos of Label.t list
| Neg of Label.t list
let all = Neg []
let positive list = Pos list
let negative list = Neg list
let match_ edge = function
| Pos labels -> Label.match_list labels edge
| Neg labels -> not (Label.match_list labels edge)
let build ?loc ?locals = function
| (edge_labels, true) -> Neg (List.map (Label.from_string ?loc ?locals) edge_labels)
| (edge_labels, false) -> Pos (List.map (Label.from_string ?loc ?locals) edge_labels)
end (* module Label_cst *)
(* ================================================================================ *)
module Domain = struct
type feature_spec =
......
......@@ -91,6 +91,17 @@ module Label : sig
val from_string: ?loc:Loc.t -> ?locals:decl array -> string -> t
end (* module Label *)
(* ================================================================================ *)
(** The module [Label_cst] defines contraints on label edges *)
module Label_cst : sig
type t
val all: t
val positive: Label.t list -> t
val negative: Label.t list -> t
val match_: Label.t -> t -> bool
val build: ?loc:Loc.t -> ?locals:Label.decl array -> (string list * bool) -> t
end (* module Label_cst *)
(* ================================================================================ *)
module Domain: sig
type feature_spec =
......
......@@ -488,53 +488,53 @@ command:
(* "shift_in m ==> n" *)
| SHIFT_IN src_loc=command_node_ident_with_loc ARROW tar=command_node_ident
{ let (src,loc) = src_loc in (Ast.Shift_in (src, tar, [], true), loc) }
{ let (src,loc) = src_loc in (Ast.Shift_in (src, tar, ([], true)), loc) }
(* "shift_in m =[x*|y]=> n" *)
| SHIFT_IN src_loc=command_node_ident_with_loc
labels=delimited(ARROW_LEFT,separated_nonempty_list(PIPE,pattern_label_ident),ARROW_RIGHT)
tar=command_node_ident
{ let (src,loc) = src_loc in (Ast.Shift_in (src, tar, labels, false), loc) }
{ let (src,loc) = src_loc in (Ast.Shift_in (src, tar, (labels, false)), loc) }
(* "shift_in m =[^x*|y]=> n" *)
| SHIFT_IN src_loc=command_node_ident_with_loc
labels=delimited(ARROW_LEFT_NEG,separated_nonempty_list(PIPE,pattern_label_ident),ARROW_RIGHT)
tar=command_node_ident
{ let (src,loc) = src_loc in (Ast.Shift_in (src, tar, labels, true), loc) }
{ let (src,loc) = src_loc in (Ast.Shift_in (src, tar, (labels, true)), loc) }
(* "shift_out m ==> n" *)
| SHIFT_OUT src_loc=command_node_ident_with_loc ARROW tar=command_node_ident
{ let (src,loc) = src_loc in (Ast.Shift_out (src, tar, [], true), loc) }
{ let (src,loc) = src_loc in (Ast.Shift_out (src, tar, ([], true)), loc) }
(* "shift_out m =[x*|y]=> n" *)
| SHIFT_OUT src_loc=command_node_ident_with_loc
labels=delimited(ARROW_LEFT,separated_nonempty_list(PIPE,pattern_label_ident),ARROW_RIGHT)
tar=command_node_ident
{ let (src,loc) = src_loc in (Ast.Shift_out (src, tar, labels, false), loc) }
{ let (src,loc) = src_loc in (Ast.Shift_out (src, tar, (labels, false)), loc) }
(* "shift_out m =[^x*|y]=> n" *)
| SHIFT_OUT src_loc=command_node_ident_with_loc
labels=delimited(ARROW_LEFT_NEG,separated_nonempty_list(PIPE,pattern_label_ident),ARROW_RIGHT)
tar=command_node_ident
{ let (src,loc) = src_loc in (Ast.Shift_out (src, tar, labels, true), loc) }
{ let (src,loc) = src_loc in (Ast.Shift_out (src, tar, (labels, true)), loc) }
(* "shift m ==> n" *)
| SHIFT src_loc=command_node_ident_with_loc ARROW tar=command_node_ident
{ let (src,loc) = src_loc in (Ast.Shift_edge (src, tar, [], true), loc) }
{ let (src,loc) = src_loc in (Ast.Shift_edge (src, tar, ([], true)), loc) }
(* "shift m =[x*|y]=> n" *)
| SHIFT src_loc=command_node_ident_with_loc
labels=delimited(ARROW_LEFT,separated_nonempty_list(PIPE,pattern_label_ident),ARROW_RIGHT)
tar=command_node_ident
{ let (src,loc) = src_loc in (Ast.Shift_edge (src, tar, labels, false), loc) }
{ let (src,loc) = src_loc in (Ast.Shift_edge (src, tar, (labels, false)), loc) }
(* "shift m =[^x*|y]=> n" *)
| SHIFT src_loc=command_node_ident_with_loc
labels=delimited(ARROW_LEFT_NEG,separated_nonempty_list(PIPE,pattern_label_ident),ARROW_RIGHT)
tar=command_node_ident
{ let (src,loc) = src_loc in (Ast.Shift_edge (src, tar, labels, true), loc) }
{ let (src,loc) = src_loc in (Ast.Shift_edge (src, tar, (labels, true)), loc) }
(* merge m ==> n *)
| MERGE src_loc=command_node_ident_with_loc ARROW tar=command_node_ident
......
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