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

@@ -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_ *)
 
 (* ================================================================================ *)

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
 
 

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

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,11 +215,14 @@ module Label = struct
     sprintf "[label=\"%s\", %s]" style.text (String.concat ", " dot_items)
 
   let from_string ?loc ?(locals=[||]) 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 ->
+          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 *)

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