Commit f3e6e5dc authored by bguillaum's avatar bguillaum

add shift_in and shift_out commands

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@6694 7838e531-6607-4d57-9587-6c381814729c
parent eea5c1d4
......@@ -68,6 +68,8 @@ type u_command =
| Del_edge_expl of (Id.name * Id.name * string)
| Del_edge_name of string
| Add_edge of (Id.name * Id.name * string)
| Shift_in of (Id.name*Id.name)
| Shift_out of (Id.name*Id.name)
| Shift_edge of (Id.name*Id.name)
| Merge_node of (Id.name*Id.name)
| New_neighbour of (Id.name * Id.name * string)
......@@ -148,6 +150,8 @@ module AST_HTML = struct
| Del_edge_expl (n1,n2,label) -> bprintf buff "del_edge %s -[%s]-> %s" n1 label n2
| Del_edge_name name -> bprintf buff "del_edge %s" name
| Add_edge (n1,n2,label) -> bprintf buff "add_edge %s -[%s]-> %s" n1 label n2
| Shift_in (n1,n2) -> bprintf buff "shift_in %s ==> %s" n1 n2
| Shift_out (n1,n2) -> bprintf buff "shift_out %s ==> %s" n1 n2
| Shift_edge (n1,n2) -> bprintf buff "shift %s ==> %s" n1 n2
| Merge_node (n1,n2) -> bprintf buff "merge %s ==> %s" n1 n2
| New_neighbour (n1,n2,label) -> bprintf buff "add_node %s: <-[%s]- %s \n" n1 label n2
......
......@@ -61,6 +61,8 @@ type u_command =
| Del_edge_expl of (Id.name * Id.name * string)
| Del_edge_name of string
| Add_edge of (Id.name * Id.name * string)
| Shift_in of (Id.name*Id.name)
| Shift_out of (Id.name*Id.name)
| Shift_edge of (Id.name*Id.name)
| Merge_node of (Id.name*Id.name)
| New_neighbour of (Id.name * Id.name * string)
......
......@@ -28,6 +28,8 @@ module Command = struct
| UPDATE_FEAT of (cnode * string * item list)
| NEW_NEIGHBOUR of (string * Edge.t * pid)
| SHIFT_EDGE of (cnode * cnode)
| SHIFT_IN of (cnode * cnode)
| SHIFT_OUT of (cnode * cnode)
| MERGE_NODE of (cnode * cnode)
type t = p * Loc.t (* remember command location to be able to localize a command failure *)
......@@ -42,6 +44,8 @@ module Command = struct
| H_UPDATE_FEAT of (gid * string * string)
| H_NEW_NEIGHBOUR of (string * Edge.t * gid)
| H_SHIFT_EDGE of (gid * gid)
| H_SHIFT_IN of (gid * gid)
| H_SHIFT_OUT of (gid * gid)
| H_MERGE_NODE of (gid * gid)
let build ?domain (kni, kei) table locals ast_command =
......@@ -77,6 +81,14 @@ module Command = struct
check_node loc i kni; check_node loc j kni;
((SHIFT_EDGE (get_pid i, get_pid j), loc), (kni, kei))
| (Ast.Shift_in (i, j), loc) ->
check_node loc i kni; check_node loc j kni;
((SHIFT_IN (get_pid i, get_pid j), loc), (kni, kei))
| (Ast.Shift_out (i, j), loc) ->
check_node loc i kni; check_node loc j kni;
((SHIFT_OUT (get_pid i, get_pid j), loc), (kni, kei))
| (Ast.Merge_node (i, j), loc) ->
check_node loc i kni; check_node loc j kni;
((MERGE_NODE (get_pid i, get_pid j), loc), (List_.rm i kni, kei))
......
......@@ -23,6 +23,8 @@ module Command : sig
| UPDATE_FEAT of (cnode * string * item list)
| NEW_NEIGHBOUR of (string * Edge.t * pid)
| SHIFT_EDGE of (cnode * cnode)
| SHIFT_IN of (cnode * cnode)
| SHIFT_OUT of (cnode * cnode)
| MERGE_NODE of (cnode * cnode)
......@@ -36,6 +38,8 @@ module Command : sig
| H_UPDATE_FEAT of (gid * string * string)
| H_NEW_NEIGHBOUR of (string * Edge.t * gid)
| H_SHIFT_EDGE of (gid * gid)
| H_SHIFT_IN of (gid * gid)
| H_SHIFT_OUT of (gid * gid)
| H_MERGE_NODE of (gid * gid)
val build:
......
......@@ -317,8 +317,46 @@ module Graph = struct
(* 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 *)
(* move all in arcs to id_src are moved to in arcs on node id_tar from graph, with all its incoming edges *)
let shift_in loc graph src_gid tar_gid =
let src_node = IntMap.find src_gid graph.map in
let tar_node = IntMap.find tar_gid graph.map in
if Massoc.mem_key src_gid tar_node.Node.next
then Error.run ~loc "[Graph.shift_in] dependency from tar to src";
let new_map =
IntMap.mapi
(fun node_id node ->
try {node with Node.next = Massoc.merge_key src_gid tar_gid node.Node.next}
with Massoc.Duplicate -> Error.run ~loc "[Graph.shift_edges] create duplicate edge"
) graph.map
in {graph with map = new_map}
(* 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 = IntMap.find src_gid graph.map in
let tar_node = IntMap.find tar_gid graph.map in
if Massoc.mem_key tar_gid src_node.Node.next
then Error.run ~loc "[Graph.shift_edges] dependency from src to tar";
let new_map =
IntMap.mapi
(fun node_id node ->
if node_id = src_gid
then (* [src_id] becomes without out-edges *)
{node with Node.next = Massoc.empty}
else if node_id = tar_gid
then
try {node with Node.next = Massoc.disjoint_union src_node.Node.next tar_node.Node.next}
with Massoc.Not_disjoint -> Error.run ~loc "[Graph.shift_edges] common successor"
else node (* other nodes don't change *)
) graph.map
in {graph with map = new_map}
(* 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 *)
let shift_edges loc graph src_gid tar_gid =
let src_node = IntMap.find src_gid graph.map in
let tar_node = IntMap.find tar_gid graph.map in
......@@ -346,6 +384,20 @@ module Graph = struct
in {graph with map = new_map}
let merge_node loc graph src_gid tar_gid =
let se_graph = shift_edges loc graph src_gid tar_gid in
......
......@@ -60,6 +60,9 @@ module Graph : sig
val add_neighbour : Loc.t -> t -> int -> Edge.t -> (int * t)
val merge_node : Loc.t -> t -> int -> int -> t option
val shift_in : Loc.t -> t -> int -> int -> t
val shift_out : Loc.t -> t -> int -> int -> t
val shift_edges : Loc.t -> t -> int -> int -> t
(** [update_feat tar_id tar_feat_name concat_items] sets the feature of the node [tar_id]
......
......@@ -55,6 +55,8 @@ let localize t = (t,get_loc ())
%token DEL_EDGE /* del_edge */
%token ADD_EDGE /* add_edge */
%token MERGE /* merge */
%token SHIFT_IN /* shift_in */
%token SHIFT_OUT /* shift_out */
%token SHIFT /* shift */
%token DEL_NODE /* del_node */
%token ADD_NODE /* add_node */
......@@ -427,6 +429,10 @@ command:
{ localize (Del_edge_expl (n1,n2,label)) }
| ADD_EDGE n1 = IDENT label = delimited(LTR_EDGE_LEFT,IDENT,LTR_EDGE_RIGHT) n2 = IDENT
{ localize (Add_edge (n1,n2,label)) }
| SHIFT_IN n1 = IDENT LONGARROW n2 = IDENT
{ localize (Shift_in (n1,n2)) }
| SHIFT_OUT n1 = IDENT LONGARROW n2 = IDENT
{ localize (Shift_out (n1,n2)) }
| SHIFT n1 = IDENT LONGARROW n2 = IDENT
{ localize (Shift_edge (n1,n2)) }
| MERGE n1 = IDENT LONGARROW n2 = IDENT
......
......@@ -67,6 +67,8 @@ and global = parse
| "add_edge" { ADD_EDGE }
| "del_edge" { DEL_EDGE }
| "shift_in" { SHIFT_IN }
| "shift_out" { SHIFT_OUT }
| "shift" { SHIFT }
| "merge" { MERGE }
| "del_node" { DEL_NODE }
......
......@@ -471,6 +471,28 @@ module Rule = struct
(created_name,new_gid) :: created_nodes
)
| Command.SHIFT_IN (src_cn,tar_cn) ->
let src_gid = node_find src_cn in
let tar_gid = node_find tar_cn in
(
{instance with
Instance.graph = Graph.shift_in loc instance.Instance.graph src_gid tar_gid;
commands = List_.sort_insert (Command.H_SHIFT_IN (src_gid,tar_gid)) instance.Instance.commands
},
created_nodes
)
| Command.SHIFT_OUT (src_cn,tar_cn) ->
let src_gid = node_find src_cn in
let tar_gid = node_find tar_cn in
(
{instance with
Instance.graph = Graph.shift_out loc instance.Instance.graph src_gid tar_gid;
commands = List_.sort_insert (Command.H_SHIFT_OUT (src_gid,tar_gid)) instance.Instance.commands
},
created_nodes
)
| Command.SHIFT_EDGE (src_cn,tar_cn) ->
let src_gid = node_find src_cn in
let tar_gid = node_find tar_cn in
......
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