! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators fry kernel locals
math math.order regexp.nfa regexp.transition-tables sequences
-sets sorting vectors sequences.deep ;
-USING: io prettyprint threads ;
+sets sorting vectors regexp.ast regexp.classes ;
IN: regexp.dfa
-:: (while-changes) ( obj quot: ( obj -- obj' ) comp: ( obj -- key ) old-key -- obj )
- obj quot call :> new-obj
- new-obj comp call :> new-key
- new-key old-key =
- [ new-obj ]
- [ new-obj quot comp new-key (while-changes) ]
- if ; inline recursive
-
-: while-changes ( obj quot pred -- obj' )
- 3dup nip call (while-changes) ; inline
-
: find-delta ( states transition nfa -- new-states )
transitions>> '[ _ swap _ at at ] gather sift ;
-: (find-epsilon-closure) ( states nfa -- new-states )
- eps swap find-delta ;
+:: epsilon-loop ( state table nfa question -- )
+ state table at :> old-value
+ old-value question 2array <or-class> :> new-question
+ new-question old-value = [
+ new-question state table set-at
+ state nfa transitions>> at
+ [ drop tagged-epsilon? ] assoc-filter
+ [| trans to |
+ to [
+ table nfa
+ trans tag>> new-question 2array <and-class>
+ epsilon-loop
+ ] each
+ ] assoc-each
+ ] unless ;
+
+: epsilon-table ( states nfa -- table )
+ [ [ H{ } clone ] dip over ] dip
+ '[ _ _ t epsilon-loop ] each ;
-: find-epsilon-closure ( states nfa -- new-states )
- '[ dup _ (find-epsilon-closure) union ] [ length ] while-changes
- natural-sort ;
+: find-epsilon-closure ( states nfa -- dfa-state )
+ epsilon-table table>condition ;
: find-closure ( states transition nfa -- new-states )
[ find-delta ] keep find-epsilon-closure ;
: find-start-state ( nfa -- state )
- [ start-state>> 1vector ] keep find-epsilon-closure ;
+ [ start-state>> 1array ] keep find-epsilon-closure ;
: find-transitions ( dfa-state nfa -- next-dfa-state )
transitions>>
- '[ _ at keys ] gather
- eps swap remove ;
+ '[ _ at keys [ condition-states ] map concat ] gather
+ [ tagged-epsilon? ] reject ;
: add-todo-state ( state visited-states new-states -- )
- 3dup drop key? [ 3drop ] [
- [ conjoin ] [ push ] bi-curry* bi
- ] if ;
+ 2over ?adjoin [ nip push ] [ 3drop ] if ;
+
+: add-todo-states ( state/condition visited-states new-states -- )
+ [ condition-states ] 2dip
+ '[ _ _ add-todo-state ] each ;
+
+: ensure-state ( key table -- )
+ 2dup key? [ 2drop ] [ [ H{ } clone ] 2dip set-at ] if ; inline
:: new-transitions ( nfa dfa new-states visited-states -- nfa dfa )
new-states [ nfa dfa ] [
pop :> state
+ state dfa transitions>> ensure-state
state nfa find-transitions
[| trans |
state trans nfa find-closure :> new-state
- new-state visited-states new-states add-todo-state
- state new-state trans transition make-transition dfa add-transition
+ new-state visited-states new-states add-todo-states
+ state new-state trans dfa set-transition
] each
nfa dfa new-states visited-states new-transitions
] if-empty ;
-: states ( hashtable -- array )
- [ keys ]
- [ values [ values concat ] map concat append ] bi ;
-
: set-final-states ( nfa dfa -- )
[
- [ final-states>> keys ]
- [ transitions>> states ] bi*
+ [ final-states>> members ]
+ [ transitions>> keys ] bi*
[ intersects? ] with filter
- ] [ final-states>> ] bi
- [ conjoin ] curry each ;
+ fast-set
+ ] keep final-states<< ;
: initialize-dfa ( nfa -- dfa )
<transition-table>
: construct-dfa ( nfa -- dfa )
dup initialize-dfa
- dup start-state>> 1vector
- H{ } clone
+ dup start-state>> condition-states >vector
+ HS{ } clone
new-transitions
[ set-final-states ] keep ;