From 74a9f052bfd5d8bc3d81f765c5c6f8bed3eb60c5 Mon Sep 17 00:00:00 2001 From: bguillaum Date: Wed, 8 Apr 2015 09:16:08 +0000 Subject: [PATCH] handling of "*" in pattern edge labels git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@8579 7838e531-6607-4d57-9587-6c381814729c --- src/grew_base.ml | 31 +++++++++++++++++++++++++++++++ src/grew_base.mli | 3 +++ src/grew_edge.ml | 17 ++++++++--------- src/grew_types.ml | 27 ++++++++++++++++++++------- src/grew_types.mli | 4 ++++ 5 files changed, 66 insertions(+), 16 deletions(-) diff --git a/src/grew_base.ml b/src/grew_base.ml index 1f35722..9794cac 100644 --- a/src/grew_base.ml +++ b/src/grew_base.ml @@ -68,6 +68,37 @@ module String_ = struct |> (Str.global_replace (Str.regexp "\\( \\|\t\\)*$") "") |> (Str.global_replace (Str.regexp "^\\( \\|\t\\)*") "") + + let rec match_star_re re s = + let star_re = Str.full_split (Str.regexp "\\*+") re in + let len = String.length s in + let rec loop pos = function + | [] -> pos = len + + | [Str.Delim "*"] -> true + + | Str.Text t :: tail -> + if Str.string_match (Str.regexp_string t) s pos + then loop (pos+(String.length t)) tail + else false + + (* if the [re] ends with some text jump to the end and test for the text *) + | [Str.Delim "*"; Str.Text t] -> + Str.string_match (Str.regexp_string t) s (len - (String.length t)) + + (* if the [re] required for some text [t], + we consider the first occurence which is more general than other occurences *) + | Str.Delim "*" :: Str.Text t :: tail -> + begin + try + let new_pos = Str.search_forward (Str.regexp_string t) s pos in + loop (new_pos+(String.length t)) tail + with Not_found -> false + end + | _ -> Error.build "Ill formed regular expression \"%s\"" re + in + loop 0 star_re + end (* module String_ *) (* ================================================================================ *) diff --git a/src/grew_base.mli b/src/grew_base.mli index cb9c884..2a1adf5 100644 --- a/src/grew_base.mli +++ b/src/grew_base.mli @@ -30,6 +30,9 @@ module String_: sig (* [rm_peripheral_white s] returns the string [s] without any white space ot tab at the beginning or at the end of the string. *) val rm_peripheral_white: string -> string + + (** [match_star_re star_re string] returns true iff the string match the [star_re] *) + val match_star_re: string -> string -> bool end diff --git a/src/grew_edge.ml b/src/grew_edge.ml index 72c279b..f88cb9c 100644 --- a/src/grew_edge.ml +++ b/src/grew_edge.ml @@ -81,26 +81,25 @@ module P_edge = struct | Binds of string * Label.t list let match_ pattern_edge graph_label = - match pattern_edge with - | {id = Some i; u_label = Pos l} when List.mem graph_label l -> Binds (i, [graph_label]) - | {id = None; u_label = Pos l} when List.mem graph_label l -> Ok graph_label - | {id = Some i; u_label = Neg l} when not (List.mem graph_label l) -> Binds (i, [graph_label]) - | {id = None; u_label = Neg l} when not (List.mem graph_label l) -> Ok graph_label + | {id = Some i; u_label = Pos l} when Label.match_list l graph_label -> Binds (i, [graph_label]) + | {id = None; u_label = Pos l} when Label.match_list l graph_label -> Ok graph_label + | {id = Some i; u_label = Neg l} when not (Label.match_list l graph_label) -> Binds (i, [graph_label]) + | {id = None; u_label = Neg l} when not (Label.match_list l graph_label) -> Ok graph_label | _ -> Fail 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 -> Label.match_list l label) 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 -> + | {id = None; u_label = Neg l} when List.exists (fun label -> not (Label.match_list l label)) graph_edge_list -> Ok (List.hd graph_edge_list) | {id = Some i; u_label = Pos l} -> - (match List.filter (fun label -> List.mem label l) graph_edge_list with + (match List.filter (fun label -> Label.match_list l label) graph_edge_list with | [] -> Fail | list -> Binds (i, list)) | {id = Some i; u_label = Neg l} -> - (match List.filter (fun label -> not (List.mem label l)) graph_edge_list with + (match List.filter (fun label -> not (Label.match_list l label)) graph_edge_list with | [] -> Fail | list -> Binds (i, list)) | _ -> Fail diff --git a/src/grew_types.ml b/src/grew_types.ml index 7980d67..61e05d8 100644 --- a/src/grew_types.ml +++ b/src/grew_types.ml @@ -132,12 +132,21 @@ module Label = struct type t = | Global of int (* globally defined labels: their names are in the [full] array *) | Local of int (* locally defined labels: names array should be provided! UNTESTED *) + | Pattern of string + + let match_ p_label g_label = match (p_label, g_label, !full) with + | (Global p, Global g, _) when p=g -> true + | (Pattern p, Global i, Some table) when String_.match_star_re p table.(i) -> true + | _ -> false + + let match_list p_label_list g_label = List.exists (fun p_label -> match_ p_label g_label) p_label_list (** [to_string t] returns a string for the label *) let to_string ?(locals=[||]) t = match (!full, t) with | (Some table, Global i) -> table.(i) | (Some _, Local i) -> fst locals.(i) + | (_, Pattern s) -> s | _ -> Error.bug "[Label.to_string] labels were not properly initialized" let to_int = function @@ -150,6 +159,7 @@ module Label = struct let get_style = function | Global i -> !styles.(i) | Local i -> Log.warning "Style of locally defined labels is not implemented"; default + | Pattern _ -> default (** Computes the style of a label from its options and maybe its shape (like I:...). *) let parse_option string_label options = @@ -205,13 +215,16 @@ module Label = struct sprintf "[label=\"%s\", %s]" style.text (String.concat ", " dot_items) let from_string ?loc ?(locals=[||]) string = - match !full with - | None -> Error.bug "[Label.from_string] labels were not properly initialized" - | Some table -> - try Global (Id.build ?loc string table) - with Not_found -> - try Local (Array_.dicho_find_assoc string locals) - with Not_found -> Error.build "[Label.from_string] unknown edge label '%s'" string + if String.contains string '*' + then Pattern string + else + match !full with + | None -> Error.bug "[Label.from_string] labels were not properly initialized" + | Some table -> + try Global (Id.build ?loc string table) + with Not_found (* TODO (CANNOT BE RAISED) *) -> + try Local (Array_.dicho_find_assoc string locals) + with Not_found -> Error.build "[Label.from_string] unknown edge label '%s'" string end (* module Label *) (* ================================================================================ *) diff --git a/src/grew_types.mli b/src/grew_types.mli index 2fadb33..f165689 100644 --- a/src/grew_types.mli +++ b/src/grew_types.mli @@ -74,6 +74,10 @@ module Label : sig type t + val match_: t -> t -> bool + + val match_list: t list -> t -> bool + val init: decl list -> unit val to_string: ?locals:decl array -> t -> string -- GitLab