Commit 0d1dcd28 authored by bguillaum's avatar bguillaum

improve label type

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@7424 7838e531-6607-4d57-9587-6c381814729c
parent ffdb961f
......@@ -6,38 +6,50 @@ open Grew_ast
(* ================================================================================ *)
module Label = struct
(* [decl] is the type for a label declaration: the name and an optionnal color *)
type decl = string * string option
type t = int
(* Global names and colors are recorded in two aligned arrays *)
let full = ref [||]
let colors = ref [||]
let init string_edge_list =
(* Internal representation of labels *)
type t =
| Global of int
| Local of int
(* [init string_edge_list] updates global arrays [full] and [colors] *)
let init string_edge_list =
let slist = List.sort (fun (x,_) (y,_) -> compare x y) string_edge_list in
let (labels, cols) = List.split slist in
full := Array.of_list labels;
colors := Array.of_list cols
let to_string t = !full.(t)
let to_int t = t
let to_string ?(locals=[||]) = function
| Global i -> !full.(i)
| Local i -> fst locals.(i)
let from_string ?loc ?(locals=[||]) string =
try Id.build ?loc string !full
with Not_found ->
try -1 - (Array_.dicho_find_assoc string locals)
let to_int = function
| Global i -> Some i
| Local _ -> None
let from_string ?loc ?(locals=[||]) string =
try Global (Id.build ?loc string !full)
with Not_found ->
try Local (Array_.dicho_find_assoc string locals)
with Not_found -> Error.build "[Label.from_string] unknown edge label '%s'" string
let get_color l = !colors.(l)
end
(* ================================================================================ *)
let get_color = function
| Global l -> !colors.(l)
| _ -> None
end (* module Label *)
(* ================================================================================ *)
module G_edge = struct
type t = Label.t
let to_string = Label.to_string
let to_string ?(locals=[||]) t = Label.to_string ~locals t
let make ?loc ?(locals=[||]) string = Label.from_string ?loc ~locals string
......@@ -59,12 +71,12 @@ module G_edge = struct
| (true,None) -> Printf.sprintf "{ label = \"%s\"; color=red}" (Label.to_string l)
| (true,Some c) -> Printf.sprintf "{ label = \"%s\"; forecolor=%s; color=red; bottom; }" (Label.to_string l) c
end
(* ================================================================================ *)
end (* module G_edge *)
(* ================================================================================ *)
module P_edge = struct
type u_label =
type u_label =
| Pos of Label.t list
| Neg of Label.t list
......@@ -83,7 +95,7 @@ module P_edge = struct
let build ?locals (ast_edge, loc) =
{ id = ast_edge.Ast.edge_id;
u_label =
u_label =
if ast_edge.Ast.negative
then Neg (List.sort compare (List.map (Label.from_string ~loc ?locals) ast_edge.Ast.edge_labels))
else Pos (List.sort compare (List.map (Label.from_string ~loc ?locals) ast_edge.Ast.edge_labels))
......@@ -116,7 +128,7 @@ module P_edge = struct
let match_list pattern_edge graph_edge_list =
match pattern_edge with
| {id = None; u_label = Pos l} when List.exists (fun label -> List.mem label l) graph_edge_list ->
| {id = None; u_label = Pos l} when List.exists (fun label -> List.mem label l) graph_edge_list ->
Ok (List.hd graph_edge_list)
| {id = None; u_label = Neg l} when List.exists (fun label -> not (List.mem label l)) graph_edge_list ->
Ok (List.hd graph_edge_list)
......@@ -130,5 +142,5 @@ module P_edge = struct
| list -> Binds (i, list))
| _ -> Fail
end
(* ================================================================================ *)
end (* module P_edge *)
......@@ -5,18 +5,19 @@ open Grew_ast
(** The module [Label] defines the type of atomic label edges *)
module Label : sig
(* a label declaration: (the label,an optionnal color) *)
(* [decl] is the type for a label declaration: the name and an optionnal color *)
type decl = string * string option
type t
val init: decl list -> unit
val to_string: t -> string
val to_int: t -> int
val to_string: ?locals:decl array -> t -> string
val to_int: t -> int option
val from_string: ?loc:Loc.t -> ?locals:decl array -> string -> t
end
val from_string: ?loc:Loc.t -> ?locals:decl array -> string -> t
end (* module Label *)
......@@ -25,7 +26,7 @@ end
module G_edge: sig
type t = Label.t
val to_string:t -> string
val to_string: ?locals:Label.decl array -> t -> string
val make: ?loc:Loc.t -> ?locals:Label.decl array -> string -> t
......@@ -33,8 +34,7 @@ module G_edge: sig
val to_dot: ?deco:bool -> t -> string
val to_dep: ?deco:bool -> t -> string
end
(* ================================================================================ *)
end (* module G_edge *)
(* ================================================================================ *)
......@@ -42,7 +42,7 @@ end
module P_edge: sig
type t
(* [all] is the joker pattern edge *)
(* [all] is the joker pattern edge *)
val all: t
val get_id: t -> string option
......@@ -59,15 +59,12 @@ module P_edge: sig
val compatible: t -> G_edge.t -> bool
type edge_matcher =
| Fail
type edge_matcher =
| Fail
| Ok of Label.t
| Binds of string * Label.t list
val match_: t -> G_edge.t -> edge_matcher
val match_list: t -> G_edge.t list -> edge_matcher
end
(* ================================================================================ *)
end (* module P_edge *)
......@@ -339,11 +339,12 @@ module G_graph = struct
let add_neighbour loc graph node_id label =
(* index is a new number (higher then lub and uniquely defined by (node_id,label) *)
(* let index = graph.lub + ((Label.to_int label) * graph.lub) + node_id in *)
let index = match node_id with
| Gid.Old id -> Gid.New (id, Label.to_int label)
| Gid.Old id ->
(match Label.to_int label with
| Some label_int -> Gid.New (id, label_int)
| None -> Error.run ~loc "[Graph.add_neighbour] try to add neighbour with a local label"
)
| Gid.New _ -> Error.run ~loc "[Graph.add_neighbour] try to add neighbour node to a neighbour node" in
if Gid_map.mem index graph.map
......
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