Commit 81b2f31f authored by bguillaum's avatar bguillaum

The shift command can be parametrized by edge constraints

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@8630 7838e531-6607-4d57-9587-6c381814729c
parent 4c7e8431
......@@ -173,9 +173,12 @@ module Ast = struct
| Del_edge_expl of (command_node_ident * command_node_ident * edge_label)
| Del_edge_name of string
| Add_edge of (command_node_ident * command_node_ident * edge_label)
| Shift_in of (command_node_ident * command_node_ident)
| Shift_out of (command_node_ident * command_node_ident)
| Shift_edge of (command_node_ident * command_node_ident)
(* 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)
| Merge_node of (command_node_ident * command_node_ident)
| New_neighbour of (Id.name * command_node_ident * edge_label)
| Del_node of command_node_ident
......@@ -185,7 +188,7 @@ module Ast = struct
| Update_feat of command_feature_ident * concat_item list
type command = u_command * Loc.t
(* the [rule] type is used for 3 kids of module items:
(* the [rule] type is used for 3 kinds of module items:
- rule { param=None; ... }
- lex_rule
- filter { param=None; commands=[]; ... }
......
......@@ -118,9 +118,12 @@ module Ast : sig
| Del_edge_expl of (command_node_ident * command_node_ident * edge_label)
| Del_edge_name of string
| Add_edge of (command_node_ident * command_node_ident * edge_label)
| Shift_in of (command_node_ident * command_node_ident)
| Shift_out of (command_node_ident * command_node_ident)
| Shift_edge of (command_node_ident * command_node_ident)
(* 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)
| Merge_node of (command_node_ident * command_node_ident)
| New_neighbour of (Id.name * command_node_ident * edge_label)
| Del_node of command_node_ident
......
......@@ -306,7 +306,7 @@ module List_ = struct
| [] -> [elt]
| x::t when compare elt x < 0 -> elt :: x :: t
| x::t when compare elt x > 0 -> x :: (loop t)
| _ -> raise Usort in
| _ -> raise Usort in
try Some (loop l) with Usort -> None
let rec sort_disjoint l1 l2 =
......@@ -418,6 +418,8 @@ module type S = sig
val add: key -> 'a -> 'a t -> 'a t option
val replace: key -> 'a list -> 'a t -> 'a t
val fold: ('b -> key -> 'a -> 'b) -> 'b -> 'a t -> 'b
(* raise Not_found if no (key,elt) *)
......@@ -466,6 +468,8 @@ module Massoc_make (Ord: OrderedType) = struct
(fun key list -> List.iter (fun elt -> fct key elt) list
) t
let replace = M.add
let add key elt t =
try
let list = M.find key t in
......
......@@ -129,6 +129,9 @@ module List_: sig
(* Insert an element in a sorted list. *)
val sort_insert: 'a -> 'a list -> 'a list
(* may raise [Not_found] *)
val usort_remove: 'a -> 'a list -> 'a list
(* Insert an element in a usort list. Return Some l or None if the element is already in the list *)
val usort_insert: ?compare:('a -> 'a -> int) -> 'a -> 'a list -> 'a list option
......@@ -187,6 +190,8 @@ module type S =
val add: key -> 'a -> 'a t -> 'a t option
val replace: key -> 'a list -> 'a t -> 'a t
val fold: ('b -> key -> 'a -> 'b) -> 'b -> 'a t -> 'b
(* raise Not_found if no (key,elt) *)
......
......@@ -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)
| SHIFT_IN of (command_node * command_node)
| SHIFT_OUT of (command_node * command_node)
| 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)
| 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), loc) ->
| (Ast.Shift_edge (act_i, act_j, labels, neg), 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))
((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))
| (Ast.Shift_in (act_i, act_j), loc) ->
| (Ast.Shift_in (act_i, act_j, labels, neg), 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))
((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))
| (Ast.Shift_out (act_i, act_j), loc) ->
| (Ast.Shift_out (act_i, act_j, labels, neg), 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))
((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))
| (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)
| SHIFT_IN of (command_node * command_node)
| SHIFT_OUT of (command_node * command_node)
| 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)
| MERGE_NODE of (command_node * command_node)
| ACT_NODE of command_node
......
......@@ -394,7 +394,7 @@ module G_graph = struct
(fun acc2 (fn,fv) -> G_fs.set_feat fn fv acc2)
G_fs.empty
(("phon", phon) :: ("cat", (List.assoc "label" t_atts)) :: other_feats) in
let new_node = G_node.set_fs (G_node.set_position (float i) G_node.empty) new_fs in
let new_node = G_node.set_fs new_fs (G_node.set_position (float i) G_node.empty) in
(Gid_map.add (Gid.Old i) new_node acc, String_map.add id (Gid.Old i) acc_map)
| _ -> Log.critical "[G_graph.of_xml] Not a wellformed <T> tag"
) (Gid_map.empty, String_map.empty) t_list in
......@@ -475,80 +475,97 @@ 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))
(* -------------------------------------------------------------------------------- *)
let shift_in loc graph src_gid tar_gid =
(* 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 src_node = Gid_map.find src_gid graph.map in
let tar_node = Gid_map.find tar_gid graph.map in
if Massoc_gid.mem_key src_gid (G_node.get_next tar_node)
then Error.run ~loc "[Graph.shift_in] dependency from tar to src";
let src_next = G_node.get_next src_node in
let tar_next = G_node.get_next tar_node in
(* Error if a loop is created by the shift_out *)
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
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)
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)
| None -> Error.run ~loc "The [shift_out] command tries to build a duplicate edge (with label \"%s\")" (Label.to_string edge)
else (acc_src_next,acc_tar_next)
)
(src_next, tar_next) src_next in
{ graph with map =
Gid_map.mapi
(fun node_id node ->
match G_node.merge_key src_gid tar_gid node with
| Some new_node -> new_node
| None -> Error.run ~loc "[Graph.shift_in] create duplicate edge"
) graph.map
graph.map
|> (Gid_map.add src_gid (G_node.set_next new_src_next src_node))
|> (Gid_map.add tar_gid (G_node.set_next new_tar_next tar_node))
}
(* -------------------------------------------------------------------------------- *)
(* move all out-edges from id_src are moved to out-edges out off node id_tar *)
let shift_out loc graph src_gid tar_gid =
let src_node = Gid_map.find src_gid graph.map in
let shift_in loc src_gid tar_gid (labels,neg) graph =
let tar_node = Gid_map.find tar_gid graph.map in
if Massoc_gid.mem_key tar_gid (G_node.get_next src_node)
then Error.run ~loc "[Graph.shift_out] dependency from src to tar";
let tar_next = G_node.get_next tar_node in
{graph with map =
(* 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
Error.run ~loc "The [shift_in] command tries to build a loop (with label \"%s\")" (Label.to_string loop_edge)
with Not_found -> () in
{ graph with map =
Gid_map.mapi
(fun node_id node ->
if node_id = src_gid
then (* [src_id] becomes without out-edges *)
G_node.rm_out_edges node
else if node_id = tar_gid
then
match G_node.shift_out src_node tar_node with
| Some n -> n
| None -> Error.run ~loc "[Graph.shift_out] common successor"
else node (* other nodes don't change *)
let node_next = G_node.get_next node in
match Massoc_gid.assoc src_gid node_next with
| [] -> node (* no edges from node to src *)
| node_src_edges ->
let node_tar_edges = Massoc_gid.assoc tar_gid node_next in
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)
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)
| Some l -> (List_.usort_remove edge acc_node_src_edges, l)
else (acc_node_src_edges,acc_node_tar_edges)
)
(node_src_edges, node_tar_edges) node_src_edges in
let new_next =
node_next
|> (Massoc_gid.replace src_gid new_node_src_edges)
|> (Massoc_gid.replace tar_gid new_node_tar_edges) in
G_node.set_next new_next node
) graph.map
}
(* -------------------------------------------------------------------------------- *)
let shift_edges loc graph src_gid tar_gid =
let src_node = Gid_map.find src_gid graph.map in
let tar_node = Gid_map.find tar_gid graph.map in
if Massoc_gid.mem_key tar_gid (G_node.get_next src_node)
then Error.run ~loc "[Graph.shift_edges] dependency from src (gid=%s) to tar (gid=%s)"
(Gid.to_string src_gid) (Gid.to_string tar_gid);
if Massoc_gid.mem_key src_gid (G_node.get_next tar_node)
then Error.run ~loc "[Graph.shift_edges] dependency from tar (gid=%s) to src (gid=%s)"
(Gid.to_string tar_gid) (Gid.to_string src_gid);
let new_map =
Gid_map.mapi
(fun node_id node ->
if node_id = src_gid
then (* [src_id] becomes an isolated node *)
G_node.rm_out_edges node
else if node_id = tar_gid
then
match G_node.shift_out src_node tar_node with
| Some n -> n
| None -> Error.run ~loc "[Graph.shift_edges] common successor"
else
match G_node.merge_key src_gid tar_gid node with
| Some n -> n
| None -> Error.run ~loc "[Graph.shift_edges] create duplicate edge"
) graph.map in
{ graph with map = new_map }
let shift_edges loc src_gid tar_gid (labels,neg) graph =
graph
|> (shift_in loc src_gid tar_gid (labels,neg))
|> (shift_out loc src_gid tar_gid (labels,neg))
(* -------------------------------------------------------------------------------- *)
let merge_node loc graph src_gid tar_gid =
let se_graph = shift_edges loc graph src_gid tar_gid in
let se_graph = shift_edges loc src_gid tar_gid ([],true) 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
......@@ -558,7 +575,7 @@ module G_graph = struct
Some {graph with map =
(Gid_map.add
tar_gid
(G_node.set_fs tar_node new_fs)
(G_node.set_fs new_fs tar_node)
(Gid_map.remove src_gid se_graph.map)
)
}
......@@ -572,7 +589,7 @@ module G_graph = struct
| "position" -> G_node.set_position (float_of_string new_value) node
| _ ->
let new_fs = G_fs.set_feat ?loc feat_name new_value (G_node.get_fs node) in
(G_node.set_fs node new_fs) in
(G_node.set_fs new_fs node) in
{ graph with map = Gid_map.add node_id new_node graph.map }
(* -------------------------------------------------------------------------------- *)
......@@ -595,7 +612,7 @@ module G_graph = struct
let del_feat graph node_id feat_name =
let node = Gid_map.find node_id graph.map in
let new_fs = G_fs.del_feat feat_name (G_node.get_fs node) in
{ graph with map = Gid_map.add node_id (G_node.set_fs node new_fs) graph.map }
{ graph with map = Gid_map.add node_id (G_node.set_fs new_fs node) graph.map }
(* -------------------------------------------------------------------------------- *)
let to_gr graph =
......
......@@ -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 -> t -> Gid.t -> Gid.t -> t
val shift_in: Loc.t -> Gid.t -> Gid.t -> (Label.t list * bool) -> t -> t
(** move all out-edges from id_src are moved to out-edges out off node id_tar *)
val shift_out: Loc.t -> t -> Gid.t -> Gid.t -> t
val shift_out: Loc.t -> Gid.t -> Gid.t -> (Label.t list * bool) -> 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 -> t -> Gid.t -> Gid.t -> t
val shift_edges: Loc.t -> Gid.t -> Gid.t -> (Label.t list * bool) -> 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].
......
......@@ -55,10 +55,28 @@ module Html_doc = struct
| Ast.Del_edge_name name -> bprintf buff "del_edge %s" name
| 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) ->
| 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_out (n1,n2) -> bprintf buff "shift_out %s ==> %s" (Ast.dump_command_node_ident n1) (Ast.dump_command_node_ident n2)
| Ast.Shift_edge (n1,n2) -> bprintf buff "shift %s ==> %s" (Ast.dump_command_node_ident n1) (Ast.dump_command_node_ident n2)
| 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) ->
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) ->
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) ->
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) ->
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) ->
bprintf buff "shift %s ==> %s" (Ast.dump_command_node_ident n1) (Ast.dump_command_node_ident n2)
| 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) ->
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)
| Ast.New_neighbour (n1,n2,label) -> bprintf buff "add_node %s: <-[%s]- %s" n1 label (Ast.dump_command_node_ident n2)
| Ast.Activate act_id -> bprintf buff "activate %s" (Ast.dump_command_node_ident act_id)
......
......@@ -27,9 +27,10 @@ module G_node = struct
}
let get_fs t = t.fs
let set_fs t fs = {t with fs = fs}
let set_fs fs t = {t with fs }
let get_next t = t.next
let set_next next t = {t with next }
let get_position t = t.position
let set_position position t = { t with position }
......
......@@ -26,8 +26,9 @@ module G_node: sig
val get_fs: t -> G_fs.t
val get_next: t -> G_edge.t Massoc_gid.t
val set_fs: t -> G_fs.t -> t
val set_fs: G_fs.t -> t -> t
val set_position: float -> t -> t
val set_next: G_edge.t Massoc_gid.t -> t -> t
val is_conll_root: t -> bool
......
......@@ -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) ->
| Command.SHIFT_IN (src_cn,tar_cn,labels,neg) ->
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 instance.Instance.graph src_gid tar_gid;
Instance.graph = G_graph.shift_in loc src_gid tar_gid (labels,neg) 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) ->
| Command.SHIFT_OUT (src_cn,tar_cn,labels,neg) ->
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 instance.Instance.graph src_gid tar_gid;
Instance.graph = G_graph.shift_out loc src_gid tar_gid (labels,neg) 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) ->
| Command.SHIFT_EDGE (src_cn,tar_cn,labels,neg) ->
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 instance.Instance.graph src_gid tar_gid;
Instance.graph = G_graph.shift_edges loc src_gid tar_gid (labels,neg) instance.Instance.graph;
history = List_.sort_insert (Command.H_SHIFT_EDGE (src_gid,tar_gid)) instance.Instance.history
},
(created_nodes, activated_nodes)
......
......@@ -49,13 +49,18 @@ let localize t = (t,get_loc ())
%token GE /* >= or */
%token PIPE /* | */
%token GOTO_NODE /* -> */
%token EDGE /* -> */
%token LTR_EDGE_LEFT /* -[ */
%token LTR_EDGE_LEFT_NEG /* -[^ */
%token LTR_EDGE_RIGHT /* ]-> */
%token RTL_EDGE_LEFT /* <-[ */
%token RTL_EDGE_RIGHT /* ]- */
%token LONGARROW /* ==> */
%token ARROW /* ==> */
%token ARROW_LEFT /* =[ */
%token ARROW_LEFT_NEG /* =[^ */
%token ARROW_RIGHT /* ]=> */
%token INCLUDE /* include */
%token FEATURES /* features */
......@@ -397,7 +402,7 @@ node_features:
pat_edge_or_const:
(* "e: A -> B" *)
| id_loc=simple_id_with_loc DDOT n1=simple_id GOTO_NODE n2=simple_id
| id_loc=simple_id_with_loc DDOT n1=simple_id EDGE n2=simple_id
{ let (id,loc) = id_loc in Pat_edge ({Ast.edge_id = Some id; src=n1; edge_labels=[]; tar=n2; negative=true}, loc) }
(* "e: A -[X|Y]-> B" *)
......@@ -412,7 +417,7 @@ pat_edge_or_const:
(* "A -> B" *)
(* "A -> *" *)
(* "* -> A" *)
| n1_loc=id_with_loc GOTO_NODE n2=ID
| n1_loc=id_with_loc EDGE n2=ID
{ let (n1,loc) = n1_loc in
match (n1,n2) with
| ("*", "*") -> Error.build ~loc "Source and target cannot be both underspecified"
......@@ -481,20 +486,58 @@ command:
| ADD_EDGE src_loc=command_node_ident_with_loc label=delimited(LTR_EDGE_LEFT,label_ident,LTR_EDGE_RIGHT) tar=command_node_ident
{ let (src,loc) = src_loc in (Ast.Add_edge (src, tar, label), loc) }
(* shift_in m ==> n *)
| SHIFT_IN src_loc=command_node_ident_with_loc LONGARROW tar=command_node_ident
{ let (src,loc) = src_loc in (Ast.Shift_in (src, tar), loc) }
(* "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) }
(* "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) }
(* "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) }
(* "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) }
(* "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) }
(* "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) }
(* "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) }
(* shift_out m ==> n *)
| SHIFT_OUT src_loc=command_node_ident_with_loc LONGARROW tar=command_node_ident
{ let (src,loc) = src_loc in (Ast.Shift_out (src, tar), 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) }
(* shift m ==> n *)
| SHIFT src_loc=command_node_ident_with_loc LONGARROW tar=command_node_ident
{ let (src,loc) = src_loc in (Ast.Shift_edge (src, tar), 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) }
(* merge m ==> n *)
| MERGE src_loc=command_node_ident_with_loc LONGARROW tar=command_node_ident
| MERGE src_loc=command_node_ident_with_loc ARROW tar=command_node_ident
{ let (src,loc) = src_loc in (Ast.Merge_node (src, tar), loc) }
(* del_node n *)
......
......@@ -142,6 +142,7 @@ and label_parser target = parse
| "]->" { Parser_global.label_flag := false; LTR_EDGE_RIGHT }
| "]-" { Parser_global.label_flag := false; RTL_EDGE_RIGHT }
| "]=>" { Parser_global.label_flag := false; ARROW_RIGHT }
| _ as c { raise (Error (sprintf "At line %d: unexpected character '%c'" (lexbuf.Lexing.lex_start_p.Lexing.pos_lnum) c)) }
......@@ -216,13 +217,17 @@ and standard target = parse
| ">=" | "" { GE }
| '|' { PIPE }
| "->" { GOTO_NODE }
| "->" { EDGE }
| "-[^" { Parser_global.label_flag := true; LTR_EDGE_LEFT_NEG }
| "-[" { Parser_global.label_flag := true; LTR_EDGE_LEFT }
| "]->" { LTR_EDGE_RIGHT }
| "<-[" { Parser_global.label_flag := true; RTL_EDGE_LEFT }
| "]-" { RTL_EDGE_RIGHT }
| "==>" { LONGARROW }
| "==>" { ARROW }
| "=[" { Parser_global.label_flag := true; ARROW_LEFT }
| "=[^" { Parser_global.label_flag := true; ARROW_LEFT_NEG }
| "]=>" { ARROW_RIGHT }
| '"' { Buffer.clear buff; string_lex global lexbuf }
......
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