Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /smlnj-lib/trunk/RegExp/BackEnd/bt-engine.sml
ViewVC logotype

Annotation of /smlnj-lib/trunk/RegExp/BackEnd/bt-engine.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2958 - (view) (download)

1 : monnier 104 (* bt-engine.sml
2 :     *
3 : jhr 2958 * COPYRIGHT (c) 2008 The Fellowship of SML/NJ (http://www.smlnj.org)
4 :     * All rights reserved.
5 : monnier 104 *
6 :     * Implements a regular expressions matcher based on a backtracking search.
7 :     *)
8 :    
9 :     structure BackTrackEngine : REGEXP_ENGINE =
10 : jhr 2958 struct
11 : monnier 104
12 : jhr 2958 exception Error
13 : monnier 104
14 : jhr 2958 structure S = RegExpSyntax
15 :     structure M = MatchTree
16 : monnier 104
17 : jhr 2958 type regexp = S.syntax
18 : monnier 104
19 : jhr 2958 (* a match specifies the position (as a stream) and the length of the match *)
20 :     type 'a match = {pos : 'a, len : int} MatchTree.match_tree
21 : monnier 104
22 : jhr 2958 fun compile r = r
23 :    
24 :     fun scan (regexp,getc,pos,stream) =
25 :     let fun getc' (s) = (case (getc (s))
26 :     of SOME v => v
27 :     | NONE => raise Subscript)
28 :     (* This function gets an empty match structure, for when the appropriate
29 :     * alternative is not followed at all
30 :     *)
31 :     fun getMatchStructure (S.Group e) = (*[M.Match (NONE,getMatchStructure e)]*) getMatchStructure e
32 :     | getMatchStructure (S.Alt l) = List.concat (map getMatchStructure l)
33 :     | getMatchStructure (S.Concat l) = List.concat (map getMatchStructure l)
34 :     | getMatchStructure (S.Interval (e,_,_)) = getMatchStructure e
35 :     | getMatchStructure (S.Option e) = getMatchStructure e
36 :     | getMatchStructure (S.Star e) = getMatchStructure e
37 :     | getMatchStructure (S.Plus e) = getMatchStructure e
38 :     | getMatchStructure (_) = []
39 :     (* Walk a regular expression in continuation-passing style
40 :     * The continuation is simply a list of all that is left to do
41 :     * Continuations only seem to arise when concatenation is considered
42 :     *
43 :     * Walk returns the boolean status of the beast, and a match_tree
44 :     * containing the match information.
45 :     * Also: the last position scanned and the remainder stream
46 :     * MODIFICATION: walk returns a list of matches
47 :     * (because we need to extract the longest match)
48 :     *)
49 :     fun max [] sel = raise Error
50 :     | max (x::xs) sel =
51 :     let fun max' [] curr currSel = curr
52 :     | max' (x::xs) curr currSel = let val xSel = sel(x)
53 :     in if (xSel>currSel)
54 :     then max' xs x xSel
55 :     else max' xs curr currSel
56 :     end
57 :     in
58 :     max' xs x (sel x)
59 :     end
60 :     fun longest l = max l (#3: 'a * 'b * int * 'c -> int)
61 :     fun optMinus1 (SOME i) = SOME (i-1)
62 :     | optMinus1 NONE = NONE
63 :     fun walk (S.Group e,cont,p,inits) =
64 :     (case walk (e,[],p,inits)
65 :     of [] => [(false,[],p,inits)]
66 :     | ((b,matches,last,s)::ls) =>
67 :     let fun loop [] cLast 1 cCont cList =
68 :     let val [(b,matches,last,s)] = cList
69 :     val [(b',matches',last',s')] = cCont
70 : monnier 104 in
71 : jhr 2958 [(b', (M.Match ({pos=inits, len=last-p},
72 :     matches))::matches',last',s')]
73 :     end
74 :     | loop [] cLast n cCont cList = raise Error
75 :     | loop ((b,matches,last,s)::es) cLen cNum cCont cList =
76 :     let val v as (_,_,last',_) = longest (walk (S.Concat [], cont,last,s))
77 :     in
78 :     if (last' > cLen)
79 :     then loop es last' 1 [v] [(b,matches,last,s)]
80 :     else if (last' = cLen)
81 :     then loop es cLen (cNum+1) (v::cCont)
82 :     ((b,matches,last,s)::cList)
83 :     else loop es cLen cNum cCont cList
84 :     end
85 :     in
86 :     loop ls last 1 [longest(walk (S.Concat [],cont,last,s))]
87 :     [(b,matches,last,s)]
88 :     end)
89 :     | walk (S.Alt [],[],p,inits) = [(true,[],p,inits)]
90 :     | walk (S.Alt [], (c::cs),p,inits) = walk (c,cs,p,inits)
91 :     | walk (S.Alt l, cont,p,inits) =
92 :     let fun loop [] = []
93 :     | loop (e::es) = let val g = longest (walk (e,cont,p,inits))
94 :     in
95 :     if (#1 g)
96 :     then g::(loop es)
97 :     else loop es
98 :     end
99 :     in
100 :     loop l
101 :     end
102 :     | walk (S.Concat [],[],p,inits) = [(true,[],p,inits)]
103 :     | walk (S.Concat [], (c::cs),p,inits) = walk (c,cs,p,inits)
104 :     | walk (S.Concat (e::es),cont,p,inits) = walk (e,(es@cont),p,inits)
105 :     | walk (S.Interval (e,0,SOME 0),[],p,inits) = [(true,[],p,inits)]
106 :     | walk (S.Interval (e,0,SOME 0),(c::cs),p,inits) = walk (c,cs,p,inits)
107 :     | walk (S.Interval(e,0,k), cont, p, inits) =
108 :     let val (b',matches',last',s') = longest (walk (S.Concat [],cont,p,inits))
109 :     val (b,matches,last,s) = longest (walk (S.Interval (e,1,k),cont,p,inits))
110 :     in
111 :     if ((b andalso b' andalso last >= last') orelse (b andalso (not b')))
112 :     then [(b,matches,last,s)]
113 :     else if ((b' andalso b andalso last' > last) orelse (b' andalso (not b)))
114 :     (* FIXME: getMatchStructure isn't really doing anything so we need to fix this code. But how? *)
115 :     then [(b',(getMatchStructure e)@matches',last',s')]
116 :     else [(false,[],p,inits)]
117 :     end
118 :     | walk (S.Interval (e,1,SOME 1),cont,p,inits) = walk (e,cont,p,inits)
119 :     | walk (S.Interval (e,1,k),cont,p,inits) =
120 :     let val (b',matches',last',s') = longest (walk (e,[],p,inits)) (* need to match 1 *)
121 :     in
122 :     if (not b')
123 :     then [(false, [], p, inits)]
124 :     else let val (b,matches,last,s) = longest (walk (S.Interval (e,1,optMinus1 k),
125 :     cont,last',s'))
126 :     val (b'',matches'',last'',s'') = longest (walk (S.Concat [],
127 :     cont,last',s'))
128 : monnier 104 in
129 : jhr 2958 if (b andalso b'' andalso last'' >= last)
130 :     then [(b'',matches'@matches'',last'',s'')]
131 :     else if (b)
132 :     then [(b,matches,last,s)]
133 :     else [(b'',matches'@matches'',last'',s'')]
134 : monnier 104 end
135 : jhr 2958 end
136 :     | walk (S.Interval (e,n1,k),cont,p,inits) =
137 :     walk (S.Concat [e,S.Interval (e,n1-1,optMinus1 k)],cont,p,inits)
138 :     | walk (S.Option e,cont,p,inits) = walk (S.Interval (e,0,SOME 1),cont,p,inits)
139 :     | walk (S.Star e,cont,p,inits) = walk (S.Interval (e,0,NONE),cont,p,inits)
140 :     | walk (S.Plus e,cont,p,inits) = walk (S.Interval (e,1,NONE),cont,p,inits)
141 :     | walk (S.MatchSet set,[],p,inits) =
142 :     if (S.CharSet.isEmpty set)
143 :     then [(true,[],p,inits)]
144 :     else
145 : monnier 104 (case (getc (inits))
146 :     of SOME (chr,s) =>
147 : jhr 2958 let val b = S.CharSet.member (set,chr)
148 : monnier 104 in
149 : jhr 2958 [(b,[],p+(if b then 1 else 0),(if b then s else inits))]
150 : monnier 104 end
151 :     | NONE => [(false,[],p,inits)])
152 : jhr 2958 | walk (S.MatchSet set,(c::cs),p,inits) =
153 :     if (S.CharSet.isEmpty set)
154 :     then walk (c,cs,p,inits)
155 :     else (case (getc (inits))
156 :     of SOME (chr,s) =>
157 :     if (S.CharSet.member (set,chr))
158 :     then walk (c,cs,(p+1),s)
159 :     else [(false,[],p,inits)]
160 :     | NONE => [(false,[],p,inits)])
161 :     | walk (S.NonmatchSet set,[],p,inits) =
162 :     (case (getc (inits))
163 :     of SOME (chr,s) =>
164 :     let val b = not (S.CharSet.member (set,chr))
165 :     in
166 :     [(b, [], p+(if b then 1 else 0),(if b then s else inits))]
167 :     end
168 :     | NONE => [(false,[],p,inits)])
169 :     | walk (S.NonmatchSet set,(c::cs),p,inits) =
170 :     (case (getc (inits))
171 :     of SOME (chr,s) => if (S.CharSet.member (set,chr))
172 :     then [(false,[],p,inits)]
173 :     else walk (c,cs,(p+1),s)
174 :     | NONE => [(false,[],p,inits)])
175 :     | walk (S.Char ch,[],p,inits) =
176 :     (case (getc (inits))
177 :     of SOME (chr,s) =>
178 :     let val b = (chr = ch)
179 :     in
180 :     [(b, [],p+(if b then 1 else 0),(if b then s else inits))]
181 :     end
182 :     | NONE => [(false,[],p,inits)])
183 :     | walk (S.Char ch,(c::cs),p,inits) =
184 :     (case (getc (inits))
185 :     of SOME (chr,s) => if (chr = ch)
186 :     then walk (c,cs,(p+1),s)
187 :     else [(false,[],p,inits)]
188 :     | NONE => [(false,[],p,inits)])
189 :     | walk (S.Begin,[],p,inits) = [(p=0,[],p,inits)]
190 :     | walk (S.Begin,(c::cs),p,inits) = if (p=0)
191 :     then walk (c,cs,p,inits)
192 :     else [(false,[],p,inits)]
193 :     | walk (S.End,[],p,inits) = [(not (Option.isSome (getc (inits))),[],p,inits)]
194 :     | walk (S.End,(c::cs),p,inits) = if (Option.isSome (getc (inits)))
195 :     then [(false,[],p,inits)]
196 :     else walk (c,cs,p,inits)
197 :     val l = walk (regexp,[],pos,stream) handle Subscript => [(false,[],pos,stream)]
198 :     val v as (result,matches,last,s') = longest l handle _ => (false,[],pos,stream)
199 :     in
200 :     if result then SOME(M.Match ({pos=stream,len=last-pos}, matches),s')
201 :     else NONE
202 :     end
203 :    
204 :     fun prefix regexp getc stream = scan (regexp,getc,0,stream)
205 : monnier 104
206 : jhr 2958 fun find regexp getc stream =
207 :     let fun loop (p,s) = (case (scan (regexp,getc,p,s))
208 :     of NONE => (case (getc (s))
209 :     of SOME (_,s') => loop (p+1,s')
210 :     | NONE => NONE)
211 :     | SOME v => SOME v)
212 :     in
213 :     loop (0,stream)
214 :     end
215 : monnier 104
216 : jhr 2958 fun match [] getc stream = NONE
217 :     | match l getc stream =
218 :     let val m = map (fn (r,f) => (scan (r, getc,0,stream), f)) l
219 :     (* find the longest SOME *)
220 :     fun loop ([],max,len) = max
221 :     | loop ((NONE,_)::xs,max,maxlen) = loop (xs,max,maxlen)
222 :     | loop ((SOME(m,cs),f)::xs,max,maxlen) =
223 :     let val {len, pos} = MatchTree.root m
224 :     in
225 :     if (len>maxlen)
226 :     then loop (xs,(SOME(m,cs),f),len)
227 :     else loop (xs,max,maxlen)
228 :     end
229 :     val (max,f) = loop (tl(m),hd(m),~1)
230 :     in
231 :     case max
232 :     of NONE => NONE
233 :     | SOME (m,cs) => SOME (f m,cs)
234 :     end
235 : monnier 104
236 :     end
237 :    
238 :    
239 :    
240 :    

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0