use reject instead of [ ... not ] filter.

[factor.git] / basis / regexp / dfa / dfa.factor

diff --git a/basis/regexp/dfa/dfa.factor b/basis/regexp/dfa/dfa.factor
index 0abd1c2edc5dc243c27c6634c686df9518495e7e..5c77741032499c70d8967074a5ba88f96cf00c8e 100644 (file)
--- a/basis/regexp/dfa/dfa.factor
+++ b/basis/regexp/dfa/dfa.factor
@@ -1,84 +1,85 @@
-! Copyright (C) 2008 Doug Coleman.
+! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
 ! 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 regexp.utils sequences.deep ;
-USING: io prettyprint threads ;
+sets sorting vectors regexp.ast regexp.classes ;
 IN: regexp.dfa
 
-: find-delta ( states transition regexp -- new-states )
-    nfa-table>> transitions>>
-    rot [ swap at at ] with with gather sift ;
+: find-delta ( states transition nfa -- new-states )
+    transitions>> '[ _ swap _ at at ] gather sift ;
 
-: (find-epsilon-closure) ( states regexp -- 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 ;
 
-: find-epsilon-closure ( states regexp -- new-states )
-    '[ dup _ (find-epsilon-closure) union ] [ length ] while-changes
-    natural-sort ;
+: epsilon-table ( states nfa -- table )
+    [ [ H{ } clone ] dip over ] dip
+    '[ _ _ t epsilon-loop ] each ;
 
-: find-closure ( states transition regexp -- new-states )
-    [ find-delta ] 2keep nip find-epsilon-closure ;
+: find-epsilon-closure ( states nfa -- dfa-state )
+    epsilon-table table>condition ;
 
-: find-start-state ( regexp -- state )
-    [ nfa-table>> start-state>> 1vector ] keep find-epsilon-closure ;
+: find-closure ( states transition nfa -- new-states )
+    [ find-delta ] keep find-epsilon-closure ;
 
-: find-transitions ( seq1 regexp -- seq2 )
-    nfa-table>> transitions>>
-    [ at keys ] curry gather
-    eps swap remove ;
+: find-start-state ( nfa -- state )
+    [ start-state>> 1array ] keep find-epsilon-closure ;
 
-: add-todo-state ( state regexp -- )
-    2dup visited-states>> key? [
-        2drop
-    ] [
-        [ visited-states>> conjoin ]
-        [ new-states>> push ] 2bi
-    ] if ;
+: find-transitions ( dfa-state nfa -- next-dfa-state )
+    transitions>>
+    '[ _ at keys [ condition-states ] map concat ] gather
+    [ tagged-epsilon? ] reject ;
 
-: new-transitions ( regexp -- )
-    dup new-states>> [
-        drop
-    ] [
-        dupd pop dup pick find-transitions rot
-        [
-            [ [ find-closure ] 2keep nip dupd add-todo-state ] 3keep
-            [ swapd transition make-transition ] dip
-            dfa-table>> add-transition 
-        ] curry with each
-        new-transitions
-    ] if-empty ;
+: add-todo-state ( state visited-states new-states -- )
+    2over ?adjoin [ nip push ] [ 3drop ] if ;
 
-: states ( hashtable -- array )
-    [ keys ]
-    [ values [ values concat ] map concat append ] bi ;
+: add-todo-states ( state/condition visited-states new-states -- )
+    [ condition-states ] 2dip
+    '[ _ _ add-todo-state ] each ;
 
-: set-final-states ( regexp -- )
-    dup
-    [ nfa-table>> final-states>> keys ]
-    [ dfa-table>> transitions>> states ] bi
-    [ intersect empty? not ] with filter
+: ensure-state ( key table -- )
+    2dup key? [ 2drop ] [ [ H{ } clone ] 2dip set-at ] if ; inline
 
-    swap dfa-table>> final-states>>
-    [ conjoin ] curry each ;
+:: 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-states
+            state new-state trans dfa set-transition
+        ] each
+        nfa dfa new-states visited-states new-transitions
+    ] if-empty ;
 
-: set-initial-state ( regexp -- )
-    dup
-    [ dfa-table>> ] [ find-start-state ] bi
-    [ >>start-state drop ] keep
-    1vector >>new-states drop ;
+: set-final-states ( nfa dfa -- )
+    [
+        [ final-states>> members ]
+        [ transitions>> keys ] bi*
+        [ intersects? ] with filter
+        fast-set
+    ] keep final-states<< ;
 
-: set-traversal-flags ( regexp -- )
-    dup
-    [ nfa-traversal-flags>> ]
-    [ dfa-table>> transitions>> keys ] bi
-    [ tuck [ swap at ] with map concat ] with H{ } map>assoc
-    >>dfa-traversal-flags drop ;
+: initialize-dfa ( nfa -- dfa )
+    <transition-table>
+        swap find-start-state >>start-state ;
 
-: construct-dfa ( regexp -- )
-    {
-        [ set-initial-state ]
-        [ new-transitions ]
-        [ set-final-states ]
-        [ set-traversal-flags ]
-    } cleave ;
+: construct-dfa ( nfa -- dfa )
+    dup initialize-dfa
+    dup start-state>> condition-states >vector
+    HS{ } clone
+    new-transitions
+    [ set-final-states ] keep ;