-! 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
- [ intersects? ] 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 ;