Commit a27a6aae authored by bguillaum's avatar bguillaum

The label_domain is encoded in GRS and is not anymore a global variable WARNING: breaks libgrew.mli

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@8833 7838e531-6607-4d57-9587-6c381814729c
parent f09d5e0d
...@@ -65,7 +65,7 @@ module Command = struct ...@@ -65,7 +65,7 @@ module Command = struct
| H_MERGE_NODE of (Gid.t * Gid.t) | H_MERGE_NODE of (Gid.t * Gid.t)
| H_ACT_NODE of (Gid.t * string) | H_ACT_NODE of (Gid.t * string)
let build domain ?param (kai, kei) table locals suffixes ast_command = let build domain label_domain ?param (kai, kei) table locals suffixes ast_command =
(* kai stands for "known act ident", kei for "known edge ident" *) (* kai stands for "known act ident", kei for "known edge ident" *)
let pid_of_act_id loc = function let pid_of_act_id loc = function
...@@ -95,7 +95,7 @@ module Command = struct ...@@ -95,7 +95,7 @@ module Command = struct
| (Ast.Del_edge_expl (act_i, act_j, lab), loc) -> | (Ast.Del_edge_expl (act_i, act_j, lab), loc) ->
check_act_id loc act_i kai; check_act_id loc act_i kai;
check_act_id loc act_j kai; check_act_id loc act_j kai;
let edge = G_edge.make ~loc ~locals lab in let edge = G_edge.make ~loc label_domain ~locals 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 (pid_of_act_id loc act_i, pid_of_act_id loc act_j, edge), loc), (kai, kei))
| (Ast.Del_edge_name id, loc) -> | (Ast.Del_edge_name id, loc) ->
...@@ -105,23 +105,23 @@ module Command = struct ...@@ -105,23 +105,23 @@ module Command = struct
| (Ast.Add_edge (act_i, act_j, lab), loc) -> | (Ast.Add_edge (act_i, act_j, lab), loc) ->
check_act_id loc act_i kai; check_act_id loc act_i kai;
check_act_id loc act_j kai; check_act_id loc act_j kai;
let edge = G_edge.make ~loc ~locals lab in let edge = G_edge.make ~loc label_domain ~locals lab in
((ADD_EDGE (pid_of_act_id loc act_i, pid_of_act_id loc act_j, edge), loc), (kai, kei)) ((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, label_cst), loc) -> | (Ast.Shift_edge (act_i, act_j, label_cst), loc) ->
check_act_id loc act_i kai; check_act_id loc act_i kai;
check_act_id loc act_j kai; check_act_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 ~locals label_cst), loc), (kai, kei)) ((SHIFT_EDGE (pid_of_act_id loc act_i, pid_of_act_id loc act_j, Label_cst.build ~loc label_domain ~locals label_cst), loc), (kai, kei))
| (Ast.Shift_in (act_i, act_j, label_cst), loc) -> | (Ast.Shift_in (act_i, act_j, label_cst), loc) ->
check_act_id loc act_i kai; check_act_id loc act_i kai;
check_act_id loc act_j kai; check_act_id loc act_j kai;
((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)) ((SHIFT_IN (pid_of_act_id loc act_i, pid_of_act_id loc act_j, Label_cst.build label_domain ~loc ~locals label_cst), loc), (kai, kei))
| (Ast.Shift_out (act_i, act_j, label_cst), loc) -> | (Ast.Shift_out (act_i, act_j, label_cst), loc) ->
check_act_id loc act_i kai; check_act_id loc act_i kai;
check_act_id loc act_j kai; check_act_id loc act_j kai;
((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)) ((SHIFT_OUT (pid_of_act_id loc act_i, pid_of_act_id loc act_j, Label_cst.build label_domain ~loc ~locals label_cst), loc), (kai, kei))
| (Ast.Merge_node (act_i, act_j), loc) -> | (Ast.Merge_node (act_i, act_j), loc) ->
check_act_id loc act_i kai; check_act_id loc act_i kai;
...@@ -133,7 +133,7 @@ module Command = struct ...@@ -133,7 +133,7 @@ module Command = struct
if List.mem (Ast.No_sharp new_id) kai if List.mem (Ast.No_sharp new_id) kai
then Error.build ~loc "Node identifier \"%s\" is already used" new_id; then Error.build ~loc "Node identifier \"%s\" is already used" new_id;
let edge = G_edge.make ~loc ~locals label in let edge = G_edge.make ~loc label_domain ~locals label in
begin begin
try try
( (
...@@ -146,7 +146,7 @@ module Command = struct ...@@ -146,7 +146,7 @@ module Command = struct
) )
with not_found -> with not_found ->
Log.fcritical "[GRS] tries to build a command New_neighbour (%s) on node %s which is not in the pattern %s" 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) (G_edge.to_string label_domain edge)
(Ast.base_command_node_ident ancestor) (Ast.base_command_node_ident ancestor)
(Loc.to_string loc) (Loc.to_string loc)
end end
......
...@@ -59,6 +59,7 @@ module Command : sig ...@@ -59,6 +59,7 @@ module Command : sig
val build: val build:
Domain.t -> Domain.t ->
Label.domain ->
?param: (string list * string list) -> ?param: (string list * string list) ->
(Ast.command_node_ident list * string list) -> (Ast.command_node_ident list * string list) ->
Id.table -> Id.table ->
......
...@@ -19,18 +19,18 @@ open Grew_ast ...@@ -19,18 +19,18 @@ open Grew_ast
module G_edge = struct module G_edge = struct
type t = Label.t type t = Label.t
let to_string ?(locals=[||]) t = Label.to_string ~locals t let to_string label_domain ?(locals=[||]) t = Label.to_string label_domain ~locals t
let make ?loc ?(locals=[||]) string = Label.from_string ?loc ~locals string let make ?loc label_domain ?(locals=[||]) string = Label.from_string ?loc label_domain ~locals string
let build ?locals (ast_edge, loc) = let build label_domain ?locals (ast_edge, loc) =
match ast_edge.Ast.edge_label_cst with match ast_edge.Ast.edge_label_cst with
| ([one], false) -> Label.from_string ~loc ?locals one | ([one], false) -> Label.from_string ~loc label_domain ?locals one
| (_, true) -> Error.build "Negative edge spec are forbidden in graphs%s" (Loc.to_string loc) | (_, true) -> Error.build "Negative edge spec are forbidden in graphs%s" (Loc.to_string loc)
| (_, false) -> Error.build "Only atomic edge valus are allowed in graphs%s" (Loc.to_string loc) | (_, false) -> Error.build "Only atomic edge valus are allowed in graphs%s" (Loc.to_string loc)
let to_dep ?(deco=false) t = Label.to_dep ~deco t let to_dep label_domain ?(deco=false) t = Label.to_dep label_domain ~deco t
let to_dot ?(deco=false) t = Label.to_dot ~deco t let to_dot label_domain ?(deco=false) t = Label.to_dot label_domain ~deco t
let color_of_option = function let color_of_option = function
| [] -> None | [] -> None
...@@ -48,41 +48,41 @@ module P_edge = struct ...@@ -48,41 +48,41 @@ module P_edge = struct
let get_id t = t.id let get_id t = t.id
let build ?locals (ast_edge, loc) = let build label_domain ?locals (ast_edge, loc) =
{ id = ast_edge.Ast.edge_id; { id = ast_edge.Ast.edge_id;
u_label = Label_cst.build ~loc ?locals ast_edge.Ast.edge_label_cst u_label = Label_cst.build ~loc label_domain ?locals ast_edge.Ast.edge_label_cst
} }
let to_string t = let to_string label_domain t =
match t.id with match t.id with
| None -> Label_cst.to_string t.u_label | None -> Label_cst.to_string label_domain t.u_label
| Some i -> sprintf "%s:%s" i (Label_cst.to_string t.u_label) | Some i -> sprintf "%s:%s" i (Label_cst.to_string label_domain t.u_label)
type edge_matcher = type edge_matcher =
| Fail | Fail
| Ok of Label.t | Ok of Label.t
| Binds of string * Label.t list | Binds of string * Label.t list
let match_ pattern_edge graph_label = let match_ label_domain pattern_edge graph_label =
match pattern_edge with match pattern_edge with
| {id = Some i; u_label = Label_cst.Pos l} when Label.match_list l graph_label -> Binds (i, [graph_label]) | {id = Some i; u_label = Label_cst.Pos l} when Label.match_list label_domain l graph_label -> Binds (i, [graph_label])
| {id = None; u_label = Label_cst.Pos l} when Label.match_list l graph_label -> Ok graph_label | {id = None; u_label = Label_cst.Pos l} when Label.match_list label_domain l graph_label -> Ok graph_label
| {id = Some i; u_label = Label_cst.Neg l} when not (Label.match_list l graph_label) -> Binds (i, [graph_label]) | {id = Some i; u_label = Label_cst.Neg l} when not (Label.match_list label_domain l graph_label) -> Binds (i, [graph_label])
| {id = None; u_label = Label_cst.Neg l} when not (Label.match_list l graph_label) -> Ok graph_label | {id = None; u_label = Label_cst.Neg l} when not (Label.match_list label_domain l graph_label) -> Ok graph_label
| _ -> Fail | _ -> Fail
let match_list pattern_edge graph_edge_list = let match_list label_domain pattern_edge graph_edge_list =
match pattern_edge with match pattern_edge with
| {id = None; u_label = Label_cst.Pos l} when List.exists (fun label -> Label.match_list l label) graph_edge_list -> | {id = None; u_label = Label_cst.Pos l} when List.exists (fun label -> Label.match_list label_domain l label) graph_edge_list ->
Ok (List.hd graph_edge_list) Ok (List.hd graph_edge_list)
| {id = None; u_label = Label_cst.Neg l} when List.exists (fun label -> not (Label.match_list l label)) graph_edge_list -> | {id = None; u_label = Label_cst.Neg l} when List.exists (fun label -> not (Label.match_list label_domain l label)) graph_edge_list ->
Ok (List.hd graph_edge_list) Ok (List.hd graph_edge_list)
| {id = Some i; u_label = Label_cst.Pos l} -> | {id = Some i; u_label = Label_cst.Pos l} ->
(match List.filter (fun label -> Label.match_list l label) graph_edge_list with (match List.filter (fun label -> Label.match_list label_domain l label) graph_edge_list with
| [] -> Fail | [] -> Fail
| list -> Binds (i, list)) | list -> Binds (i, list))
| {id = Some i; u_label = Label_cst.Neg l} -> | {id = Some i; u_label = Label_cst.Neg l} ->
(match List.filter (fun label -> not (Label.match_list l label)) graph_edge_list with (match List.filter (fun label -> not (Label.match_list label_domain l label)) graph_edge_list with
| [] -> Fail | [] -> Fail
| list -> Binds (i, list)) | list -> Binds (i, list))
| _ -> Fail | _ -> Fail
......
...@@ -18,14 +18,14 @@ open Grew_ast ...@@ -18,14 +18,14 @@ open Grew_ast
module G_edge: sig module G_edge: sig
type t = Label.t type t = Label.t
val to_string: ?locals:Label.decl array -> t -> string val to_string: Label.domain -> ?locals:Label.decl array -> t -> string
val make: ?loc:Loc.t -> ?locals:Label.decl array -> string -> t val make: ?loc:Loc.t -> Label.domain -> ?locals:Label.decl array -> string -> t
val build: ?locals:Label.decl array -> Ast.edge -> t val build: Label.domain -> ?locals:Label.decl array -> Ast.edge -> t
val to_dot: ?deco:bool -> t -> string val to_dot: Label.domain -> ?deco:bool -> t -> string
val to_dep: ?deco:bool -> t -> string val to_dep: Label.domain -> ?deco:bool -> t -> string
end (* module G_edge *) end (* module G_edge *)
(* ================================================================================ *) (* ================================================================================ *)
...@@ -38,16 +38,16 @@ module P_edge: sig ...@@ -38,16 +38,16 @@ module P_edge: sig
val get_id: t -> string option val get_id: t -> string option
val to_string: t -> string val to_string: Label.domain -> t -> string
val build: ?locals:Label.decl array -> Ast.edge -> t val build: Label.domain -> ?locals:Label.decl array -> Ast.edge -> t
type edge_matcher = type edge_matcher =
| Fail | Fail
| Ok of Label.t | Ok of Label.t
| Binds of string * Label.t list | Binds of string * Label.t list
val match_: t -> G_edge.t -> edge_matcher val match_: Label.domain -> t -> G_edge.t -> edge_matcher
val match_list: t -> G_edge.t list -> edge_matcher val match_list: Label.domain -> t -> G_edge.t list -> edge_matcher
end (* module P_edge *) end (* module P_edge *)
...@@ -53,7 +53,7 @@ module P_graph = struct ...@@ -53,7 +53,7 @@ module P_graph = struct
(pid, fs) (pid, fs)
(* -------------------------------------------------------------------------------- *) (* -------------------------------------------------------------------------------- *)
let build domain ?pat_vars ?(locals=[||]) (full_node_list : Ast.node list) full_edge_list = let build domain label_domain ?pat_vars ?(locals=[||]) (full_node_list : Ast.node list) full_edge_list =
(* NB: insert searches for a previous node with the Same name and uses unification rather than constraint *) (* NB: insert searches for a previous node with the Same name and uses unification rather than constraint *)
(* NB: insertion of new node at the end of the list: not efficient but graph building is not the hard part. *) (* NB: insertion of new node at the end of the list: not efficient but graph building is not the hard part. *)
...@@ -87,11 +87,11 @@ module P_graph = struct ...@@ -87,11 +87,11 @@ module P_graph = struct
(fun acc (ast_edge, loc) -> (fun acc (ast_edge, loc) ->
let i1 = Id.build ~loc ast_edge.Ast.src pos_table in let i1 = Id.build ~loc ast_edge.Ast.src pos_table in
let i2 = Id.build ~loc ast_edge.Ast.tar pos_table in let i2 = Id.build ~loc ast_edge.Ast.tar pos_table in
let edge = P_edge.build ~locals (ast_edge, loc) in let edge = P_edge.build label_domain ~locals (ast_edge, loc) in
(match map_add_edge acc (Pid.Pos i1) edge (Pid.Pos i2) with (match map_add_edge acc (Pid.Pos i1) edge (Pid.Pos i2) with
| Some g -> g | Some g -> g
| None -> Error.build "[GRS] [Graph.build] try to build a graph with twice the same edge %s %s" | None -> Error.build "[GRS] [Graph.build] try to build a graph with twice the same edge %s %s"
(P_edge.to_string edge) (P_edge.to_string label_domain edge)
(Loc.to_string loc) (Loc.to_string loc)
) )
) map_without_edges full_edge_list in ) map_without_edges full_edge_list in
...@@ -108,7 +108,7 @@ module P_graph = struct ...@@ -108,7 +108,7 @@ module P_graph = struct
(* -------------------------------------------------------------------------------- *) (* -------------------------------------------------------------------------------- *)
(* It may raise [P_fs.Fail_unif] in case of contradiction on constraints *) (* It may raise [P_fs.Fail_unif] in case of contradiction on constraints *)
let build_extension domain ?pat_vars ?(locals=[||]) pos_table full_node_list full_edge_list = let build_extension domain label_domain ?pat_vars ?(locals=[||]) pos_table full_node_list full_edge_list =
let built_nodes = List.map (P_node.build domain ?pat_vars) full_node_list in let built_nodes = List.map (P_node.build domain ?pat_vars) full_node_list in
...@@ -154,7 +154,7 @@ module P_graph = struct ...@@ -154,7 +154,7 @@ module P_graph = struct
match Id.build_opt tar pos_table with match Id.build_opt tar pos_table with
| Some i -> Pid.Pos i | Some i -> Pid.Pos i
| None -> Pid.Neg (Id.build ~loc tar new_table) in | None -> Pid.Neg (Id.build ~loc tar new_table) in
let edge = P_edge.build ~locals (ast_edge, loc) in let edge = P_edge.build label_domain ~locals (ast_edge, loc) in
match map_add_edge acc i1 edge i2 with match map_add_edge acc i1 edge i2 with
| Some map -> map | Some map -> map
| None -> Log.fbug "[GRS] [Graph.build_extension] add_edge cannot fail in pattern extension"; exit 2 | None -> Log.fbug "[GRS] [Graph.build_extension] add_edge cannot fail in pattern extension"; exit 2
...@@ -262,9 +262,9 @@ module G_graph = struct ...@@ -262,9 +262,9 @@ module G_graph = struct
in loop 0 in loop 0
(* is there an edge e out of node i ? *) (* is there an edge e out of node i ? *)
let edge_out graph node_id label_cst = let edge_out label_domain graph node_id label_cst =
let node = Gid_map.find node_id graph.map in let node = Gid_map.find node_id graph.map in
Massoc_gid.exists (fun _ e -> Label_cst.match_ e label_cst) (G_node.get_next node) Massoc_gid.exists (fun _ e -> Label_cst.match_ label_domain e label_cst) (G_node.get_next node)
let get_annot_info graph = let get_annot_info graph =
let annot_info = let annot_info =
...@@ -295,7 +295,7 @@ module G_graph = struct ...@@ -295,7 +295,7 @@ module G_graph = struct
| None -> None | None -> None
(* -------------------------------------------------------------------------------- *) (* -------------------------------------------------------------------------------- *)
let build domain ?(locals=[||]) gr_ast = let build domain label_domain ?(locals=[||]) gr_ast =
let full_node_list = gr_ast.Ast.nodes let full_node_list = gr_ast.Ast.nodes
and full_edge_list = gr_ast.Ast.edges in and full_edge_list = gr_ast.Ast.edges in
...@@ -329,11 +329,11 @@ module G_graph = struct ...@@ -329,11 +329,11 @@ module G_graph = struct
(fun acc (ast_edge, loc) -> (fun acc (ast_edge, loc) ->
let i1 = Id.build ~loc ast_edge.Ast.src table in let i1 = Id.build ~loc ast_edge.Ast.src table in
let i2 = Id.build ~loc ast_edge.Ast.tar table in let i2 = Id.build ~loc ast_edge.Ast.tar table in
let edge = G_edge.build ~locals (ast_edge, loc) in let edge = G_edge.build label_domain ~locals (ast_edge, loc) in
(match map_add_edge acc (Gid.Old i1) edge (Gid.Old i2) with (match map_add_edge acc (Gid.Old i1) edge (Gid.Old i2) with
| Some g -> g | Some g -> g
| None -> Error.build "[GRS] [Graph.build] try to build a graph with twice the same edge %s %s" | None -> Error.build "[GRS] [Graph.build] try to build a graph with twice the same edge %s %s"
(G_edge.to_string edge) (G_edge.to_string label_domain edge)
(Loc.to_string loc) (Loc.to_string loc)
) )
) map_without_edges full_edge_list in ) map_without_edges full_edge_list in
...@@ -343,7 +343,7 @@ module G_graph = struct ...@@ -343,7 +343,7 @@ module G_graph = struct
(* -------------------------------------------------------------------------------- *) (* -------------------------------------------------------------------------------- *)
let of_conll ?loc domain (meta, lines, range_lines) = let of_conll ?loc domain label_domain (meta, lines, range_lines) =
let sorted_lines = Conll.root :: (List.sort Conll.compare lines) in let sorted_lines = Conll.root :: (List.sort Conll.compare lines) in
let gtable = (Array.of_list (List.map (fun line -> line.Conll.num) sorted_lines), string_of_int) in let gtable = (Array.of_list (List.map (fun line -> line.Conll.num) sorted_lines), string_of_int) in
...@@ -363,11 +363,11 @@ module G_graph = struct ...@@ -363,11 +363,11 @@ module G_graph = struct
List.fold_left List.fold_left
(fun acc2 (gov, dep_lab) -> (fun acc2 (gov, dep_lab) ->
let gov_id = Id.gbuild ?loc gov gtable in let gov_id = Id.gbuild ?loc gov gtable in
let edge = G_edge.make ?loc dep_lab in let edge = G_edge.make label_domain ?loc dep_lab in
(match map_add_edge acc2 (Gid.Old gov_id) edge (Gid.Old dep_id) with (match map_add_edge acc2 (Gid.Old gov_id) edge (Gid.Old dep_id) with
| Some g -> g | Some g -> g
| None -> Error.build "[GRS] [Graph.of_conll] try to build a graph with twice the same edge %s %s" | None -> Error.build "[GRS] [Graph.of_conll] try to build a graph with twice the same edge %s %s"
(G_edge.to_string edge) (G_edge.to_string label_domain edge)
(match loc with Some l -> Loc.to_string l | None -> "") (match loc with Some l -> Loc.to_string l | None -> "")
) )
) acc line.Conll.deps ) acc line.Conll.deps
...@@ -386,7 +386,7 @@ module G_graph = struct ...@@ -386,7 +386,7 @@ module G_graph = struct
(* -------------------------------------------------------------------------------- *) (* -------------------------------------------------------------------------------- *)
(** input : "Le/DET/le petit/ADJ/petit chat/NC/chat dort/V/dormir ./PONCT/." *) (** input : "Le/DET/le petit/ADJ/petit chat/NC/chat dort/V/dormir ./PONCT/." *)
let of_brown domain ?sentid brown = let of_brown domain label_domain ?sentid brown =
let units = Str.split (Str.regexp " ") brown in let units = Str.split (Str.regexp " ") brown in
let conll_lines = List.mapi let conll_lines = List.mapi
(fun i item -> match Str.full_split (Str.regexp "/[A-Z'+'']+/") item with (fun i item -> match Str.full_split (Str.regexp "/[A-Z'+'']+/") item with
...@@ -407,7 +407,7 @@ module G_graph = struct ...@@ -407,7 +407,7 @@ module G_graph = struct
} }
| _ -> Error.build "[Graph.of_brown] Cannot parse Brown item >>>%s<<< (expected \"phon/POS/lemma\")" item | _ -> Error.build "[Graph.of_brown] Cannot parse Brown item >>>%s<<< (expected \"phon/POS/lemma\")" item
) units in ) units in
of_conll domain ([], conll_lines, []) of_conll domain label_domain ([], conll_lines, [])
(* -------------------------------------------------------------------------------- *) (* -------------------------------------------------------------------------------- *)
let opt_att atts name = let opt_att atts name =
...@@ -416,7 +416,7 @@ module G_graph = struct ...@@ -416,7 +416,7 @@ module G_graph = struct
(* -------------------------------------------------------------------------------- *) (* -------------------------------------------------------------------------------- *)
(** [of_xml d_xml] loads a graph in the xml format: [d_xml] must be a <D> xml element *) (** [of_xml d_xml] loads a graph in the xml format: [d_xml] must be a <D> xml element *)
let of_xml domain d_xml = let of_xml domain label_domain d_xml =
match d_xml with match d_xml with
| Xml.Element ("D", _, t_or_r_list) -> | Xml.Element ("D", _, t_or_r_list) ->
let (t_list, r_list) = List.partition (function Xml.Element ("T",_,_) -> true | _ -> false) t_or_r_list in let (t_list, r_list) = List.partition (function Xml.Element ("T",_,_) -> true | _ -> false) t_or_r_list in
...@@ -448,7 +448,7 @@ module G_graph = struct ...@@ -448,7 +448,7 @@ module G_graph = struct
let gid_src = String_map.find src mapping in let gid_src = String_map.find src mapping in
let old_node = Gid_map.find gid_src acc in let old_node = Gid_map.find gid_src acc in
let new_map = let new_map =
match G_node.add_edge (G_edge.make label) gid_tar old_node with match G_node.add_edge (G_edge.make label_domain label) gid_tar old_node with
| Some new_node -> Gid_map.add gid_src new_node acc | Some new_node -> Gid_map.add gid_src new_node acc
| None -> Log.critical "[G_graph.of_xml] Fail to add edge" in | None -> Log.critical "[G_graph.of_xml] Fail to add edge" in
new_map new_map
...@@ -458,7 +458,7 @@ module G_graph = struct ...@@ -458,7 +458,7 @@ module G_graph = struct
| _ -> Log.critical "[G_graph.of_xml] Not a <D> tag" | _ -> Log.critical "[G_graph.of_xml] Not a <D> tag"
(* -------------------------------------------------------------------------------- *) (* -------------------------------------------------------------------------------- *)
let del_edge ?edge_ident loc graph id_src label id_tar = let del_edge label_domain ?edge_ident loc graph id_src label id_tar =
let node_src = let node_src =
try Gid_map.find id_src graph.map try Gid_map.find id_src graph.map
with Not_found -> with Not_found ->
...@@ -466,7 +466,7 @@ module G_graph = struct ...@@ -466,7 +466,7 @@ module G_graph = struct
| None -> Log.fcritical "[RUN] Some edge refers to a dead node, please report" | None -> Log.fcritical "[RUN] Some edge refers to a dead node, please report"
| Some id -> Error.run ~loc "[Graph.del_edge] cannot find source node of edge \"%s\"" id in | Some id -> Error.run ~loc "[Graph.del_edge] cannot find source node of edge \"%s\"" id in
try {graph with map = Gid_map.add id_src (G_node.remove id_tar label node_src) graph.map} try {graph with map = Gid_map.add id_src (G_node.remove id_tar label node_src) graph.map}
with Not_found -> Error.run ~loc "[Graph.del_edge] cannot find edge '%s'" (G_edge.to_string label) with Not_found -> Error.run ~loc "[Graph.del_edge] cannot find edge '%s'" (G_edge.to_string label_domain label)
(* -------------------------------------------------------------------------------- *) (* -------------------------------------------------------------------------------- *)
let del_node graph node_id = let del_node graph node_id =
...@@ -493,7 +493,7 @@ module G_graph = struct ...@@ -493,7 +493,7 @@ module G_graph = struct
(index, {graph with map = new_map}) (index, {graph with map = new_map})
(* -------------------------------------------------------------------------------- *) (* -------------------------------------------------------------------------------- *)
let add_neighbour loc graph node_id label = let add_neighbour loc label_domain graph node_id label =
let index = match node_id with let index = match node_id with
| Gid.Old id -> | Gid.Old id ->
(match Label.to_int label with (match Label.to_int label with
...@@ -503,7 +503,7 @@ module G_graph = struct ...@@ -503,7 +503,7 @@ module G_graph = struct
| Gid.New _ | Gid.Act _ -> Error.run ~loc "[Graph.add_neighbour] try to add neighbour node to a neighbour node" in | Gid.New _ | Gid.Act _ -> Error.run ~loc "[Graph.add_neighbour] try to add neighbour node to a neighbour node" in
if Gid_map.mem index graph.map if Gid_map.mem index graph.map
then Error.run ~loc "[Graph.add_neighbour] try to build twice the \"same\" neighbour node (with label '%s')" (Label.to_string label); then Error.run ~loc "[Graph.add_neighbour] try to build twice the \"same\" neighbour node (with label '%s')" (Label.to_string label_domain label);
let node = Gid_map.find node_id graph.map in let node = Gid_map.find node_id graph.map in
(* put the new node on the right of its "parent" *) (* put the new node on the right of its "parent" *)
...@@ -515,7 +515,7 @@ module G_graph = struct ...@@ -515,7 +515,7 @@ module G_graph = struct
(* -------------------------------------------------------------------------------- *) (* -------------------------------------------------------------------------------- *)
(* move out-edges (which respect cst [labels,neg]) from id_src are moved to out-edges out off node id_tar *) (* 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 label_cst graph = let shift_out loc label_domain src_gid tar_gid label_cst graph =
let src_node = Gid_map.find src_gid graph.map in let src_node = Gid_map.find src_gid graph.map in
let tar_node = Gid_map.find tar_gid graph.map in let tar_node = Gid_map.find tar_gid graph.map in
...@@ -526,18 +526,18 @@ module G_graph = struct ...@@ -526,18 +526,18 @@ module G_graph = struct
let src_tar_edges = Massoc_gid.assoc tar_gid src_next in let src_tar_edges = Massoc_gid.assoc tar_gid src_next in
let _ = let _ =
try try
let loop_edge = List.find (fun edge -> Label_cst.match_ edge label_cst) src_tar_edges in let loop_edge = List.find (fun edge -> Label_cst.match_ label_domain 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) Error.run ~loc "The shfit_out command tries to build a loop (with label %s)" (Label.to_string label_domain loop_edge)
with Not_found -> () in with Not_found -> () in
let (new_src_next,new_tar_next) = let (new_src_next,new_tar_next) =
Massoc_gid.fold Massoc_gid.fold
(fun (acc_src_next,acc_tar_next) next_gid edge -> (fun (acc_src_next,acc_tar_next) next_gid edge ->
if Label_cst.match_ edge label_cst if Label_cst.match_ label_domain edge label_cst
then then
match Massoc_gid.add next_gid edge acc_tar_next with 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) | 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) | None -> Error.run ~loc "The [shift_out] command tries to build a duplicate edge (with label \"%s\")" (Label.to_string label_domain edge)
else (acc_src_next,acc_tar_next) else (acc_src_next,acc_tar_next)
) )
...@@ -550,7 +550,7 @@ module G_graph = struct ...@@ -550,7 +550,7 @@ module G_graph = struct
} }
(* -------------------------------------------------------------------------------- *) (* -------------------------------------------------------------------------------- *)
let shift_in loc src_gid tar_gid label_cst graph = let shift_in loc label_domain src_gid tar_gid label_cst graph =
let tar_node = Gid_map.find tar_gid graph.map in let tar_node = Gid_map.find tar_gid graph.map in
let tar_next = G_node.get_next tar_node in let tar_next = G_node.get_next tar_node in
...@@ -558,8 +558,8 @@ module G_graph = struct ...@@ -558,8 +558,8 @@ module G_graph = struct