--- /dev/null
+(* $Id$
+ * ----------------------------------------------------------------------
+ *
+ *)
+
+module StringOrd = struct
+ type t = string
+ let compare = (compare : string -> string -> int)
+end;;
+
+module StringMap = Map.Make(StringOrd);;
+ (* 'a StringMap.t: the type of maps (dictionaries) from string to 'a *)
+
+module Graph = struct
+ type vertex =
+ { mutable edges_out : (string * vertex) list;
+ mutable edges_out_map : vertex StringMap.t;
+ mutable edges_in : (vertex * string) list;
+ mutable graph : graph;
+ mutable id : int;
+ }
+ and graph =
+ { mutable vertexes : vertex list;
+ mutable mid : int; (* maximum id + 1 *)
+ }
+
+ exception Edge_not_unique
+
+ let create () =
+ { vertexes = [];
+ mid = 0;
+ }
+
+ let new_vertex g =
+ let v =
+ { edges_out = [];
+ edges_out_map = StringMap.empty;
+ edges_in = [];
+ graph = g;
+ id = g.mid;
+ } in
+ g.vertexes <- v :: g.vertexes;
+ g.mid <- g.mid + 1;
+ v
+
+ let new_edge v_from e v_to =
+ if v_from.graph != v_to.graph then
+ invalid_arg "Pxp_dfa.Graph.new_edge";
+ try
+ let v = StringMap.find e v_from.edges_out_map in
+ if v != v_to then
+ raise Edge_not_unique;
+ with
+ Not_found ->
+ v_from.edges_out <- (e, v_to) :: v_from.edges_out;
+ v_from.edges_out_map <- StringMap.add e v_to v_from.edges_out_map;
+ v_to.edges_in <- (v_from, e) :: v_to.edges_in;
+ ()
+
+ let graph_of_vertex v = v.graph
+
+ let union g1 g2 =
+ List.iter
+ (fun v ->
+ v.graph <- g1;
+ v.id <- v.id + g1.mid;
+ )
+ g2.vertexes;
+ g1.vertexes <- g2.vertexes @ g1.vertexes;
+ g1.mid <- g1.mid + g2.mid;
+ g2.vertexes <- [];
+ g2.mid <- 0
+
+ let outgoing_edges v =
+ v.edges_out
+
+ let ingoing_edges v =
+ v.edges_in
+
+ let follow_edge v e =
+ StringMap.find e v.edges_out_map (* or raise Not_found *)
+end
+;;
+
+
+module VertexOrd = struct
+ type t = Graph.vertex
+ let compare v1 v2 =
+ if v1.Graph.graph != v2.Graph.graph then
+ invalid_arg "Pxp_dfa.VertexOrd.compare";
+ compare v1.Graph.id v2.Graph.id
+end
+;;
+
+module VertexSet = Set.Make(VertexOrd);;
+
+
+type dfa_definition =
+ { dfa_graph : Graph.graph;
+ dfa_start : Graph.vertex;
+ dfa_stops : VertexSet.t;
+ dfa_null : bool;
+ }
+;;
+
+(**********************************************************************)
+
+(* Now that we have all the auxiliary data types, it is time for the
+ * algorithm that transforms regexps to DFAs.
+ *)
+
+open Pxp_types
+
+let dfa_of_regexp_content_model re =
+ let rec get_dfa re =
+ match re with
+ Child e ->
+ let g = Graph.create() in
+ let v1 = Graph.new_vertex g in
+ let v2 = Graph.new_vertex g in
+ Graph.new_edge v1 e v2;
+ { dfa_graph = g;
+ dfa_start = v1;
+ dfa_stops = VertexSet.singleton v2;
+ dfa_null = false;
+ }
+
+ | Seq [] ->
+ invalid_arg "Pxp_dfa.dfa_of_regexp_content_model"
+ | Seq [re'] ->
+ get_dfa re'
+ | Seq (re1 :: seq2) ->
+ let dfa1 = get_dfa re1 in
+ let dfa2 = get_dfa (Seq seq2) in
+ (* Merge the two graphs. The result is in dfa1.dfa_graph: *)
+ Graph.union dfa1.dfa_graph dfa2.dfa_graph;
+ (* Concatenation I: Add additional edges to the graph such
+ * that if w1 matches dfa1, and w2 matches dfa2, and w2 is not
+ * empty, w1w2 will match the merged DFAs.
+ *)
+ List.iter
+ (fun (e,v') ->
+ VertexSet.iter
+ (fun v ->
+ Graph.new_edge v e v')
+ dfa1.dfa_stops
+ )
+ (Graph.outgoing_edges dfa2.dfa_start);
+ (* Concatenation II: If the emtpy string matches dfa2, the stop
+ * nodes of dfa1 remain stop nodes.
+ *)
+ let stops =
+ if dfa2.dfa_null then
+ VertexSet.union dfa1.dfa_stops dfa2.dfa_stops
+ else
+ dfa2.dfa_stops
+ in
+ (* The resulting DFA: *)
+ { dfa_graph = dfa1.dfa_graph;
+ dfa_start = dfa1.dfa_start;
+ dfa_stops = stops;
+ dfa_null = dfa1.dfa_null && dfa2.dfa_null;
+ }
+
+ | Alt [] ->
+ invalid_arg "Pxp_dfa.dfa_of_regexp_content_model"
+ | Alt [re'] ->
+ get_dfa re'
+ | Alt alt ->
+ let dfa_alt = List.map get_dfa alt in
+ (* Merge the graphs. The result is in g: *)
+ let g = (List.hd dfa_alt).dfa_graph in
+ List.iter
+ (fun dfa ->
+ Graph.union g dfa.dfa_graph
+ )
+ (List.tl dfa_alt);
+ (* Get the new start node: *)
+ let start = Graph.new_vertex g in
+ (* Add the new edges starting at 'start': *)
+ List.iter
+ (fun dfa ->
+ List.iter
+ (fun (e, v) ->
+ Graph.new_edge start e v)
+ (Graph.outgoing_edges dfa.dfa_start)
+ )
+ dfa_alt;
+ (* If one of the old start nodes was a stop node, the new start
+ * node will be a stop node, too.
+ *)
+ let null = List.exists (fun dfa -> dfa.dfa_null) dfa_alt in
+ let stops =
+ List.fold_left
+ (fun s dfa -> VertexSet.union s dfa.dfa_stops)
+ VertexSet.empty
+ dfa_alt in
+ let stops' =
+ if null then
+ VertexSet.union stops (VertexSet.singleton start)
+ else
+ stops in
+ (* The resulting DFA: *)
+ { dfa_graph = g;
+ dfa_start = start;
+ dfa_stops = stops';
+ dfa_null = null;
+ }
+
+ | Optional re' ->
+ let dfa' = get_dfa re' in
+ if dfa'.dfa_null then
+ (* simple case *)
+ dfa'
+ else begin
+ (* Optimization possible: case ingoing_edges dfa_start = [] *)
+ let start = Graph.new_vertex dfa'.dfa_graph in
+ List.iter
+ (fun (e, v) ->
+ Graph.new_edge start e v)
+ (Graph.outgoing_edges dfa'.dfa_start);
+
+ (* The resulting DFA: *)
+ { dfa_graph = dfa'.dfa_graph;
+ dfa_start = start;
+ dfa_stops = VertexSet.union dfa'.dfa_stops
+ (VertexSet.singleton start);
+ dfa_null = true;
+ }
+ end
+
+ | Repeated1 re' ->
+ let dfa' = get_dfa re' in
+ List.iter
+ (fun (e, v') ->
+ VertexSet.iter
+ (fun v ->
+ Graph.new_edge v e v')
+ dfa'.dfa_stops
+ )
+ (Graph.outgoing_edges dfa'.dfa_start);
+
+ (* The resulting DFA: *)
+ { dfa_graph = dfa'.dfa_graph;
+ dfa_start = dfa'.dfa_start;
+ dfa_stops = dfa'.dfa_stops;
+ dfa_null = dfa'.dfa_null;
+ }
+
+ | Repeated re' ->
+ get_dfa (Optional (Repeated1 re'))
+
+ in
+ try
+ get_dfa re
+ with
+ Graph.Edge_not_unique -> raise Not_found
+;;
+
+(* ======================================================================
+ * History:
+ *
+ * $Log$
+ * Revision 1.1 2000/11/17 09:57:29 lpadovan
+ * Initial revision
+ *
+ * Revision 1.1 2000/07/23 02:16:08 gerd
+ * Initial revision.
+ *
+ *
+ *)
projects / helm.git / blobdiff