! 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.ast ;
+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 )
- epsilon swap find-delta ;
+TUPLE: condition question yes no ;
+C: <condition> condition
+
+:: 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 ;
+
+GENERIC# replace-question 2 ( class from to -- new-class )
+
+M: object replace-question
+ [ [ = ] keep ] dip swap ? ;
+
+: replace-compound ( class from to -- seq )
+ [ seq>> ] 2dip '[ _ _ replace-question ] map ;
+
+M: and-class replace-question
+ replace-compound <and-class> ;
+
+M: or-class replace-question
+ replace-compound <or-class> ;
+
+: answer ( table question answer -- new-table )
+ '[ _ _ replace-question ] assoc-map
+ [ nip ] assoc-filter ;
+
+DEFER: make-condition
+
+: (make-condition) ( table questions question -- condition )
+ [ 2nip ]
+ [ swap [ t answer ] dip make-condition ]
+ [ swap [ f answer ] dip make-condition ] 3tri
+ <condition> ;
+
+: make-condition ( table questions -- condition )
+ [ keys ] [ unclip (make-condition) ] if-empty ;
+
+GENERIC: class>questions ( class -- questions )
+: compound-questions ( class -- questions ) seq>> [ class>questions ] gather ;
+M: or-class class>questions compound-questions ;
+M: and-class class>questions compound-questions ;
+M: object class>questions 1array ;
+
+: table>condition ( table -- condition )
+ ! This is wrong, since actually an arbitrary and-class or or-class can be used
+ dup
+ values <or-class> class>questions t swap remove
+ make-condition ;
+
+: epsilon-table ( states nfa -- table )
+ [ H{ } clone tuck ] 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>>
[| trans |
state trans nfa find-closure :> new-state
new-state visited-states new-states add-todo-state
- state new-state trans dfa add-transition
+ state new-state trans dfa set-transition
] each
nfa dfa new-states visited-states new-transitions
] if-empty ;
: maybe-initialize-key ( key hashtable -- )
2dup key? [ 2drop ] [ [ H{ } clone ] 2dip set-at ] if ;
-:: set-transition ( from to obj hash -- )
+:: (set-transition) ( from to obj hash -- )
+ to hash maybe-initialize-key
+ from hash at
+ [ [ to obj ] dip set-at ]
+ [ to obj associate from hash set-at ] if* ;
+
+: set-transition ( from to obj transition-table -- )
+ transitions>> (set-transition) ;
+
+:: (add-transition) ( from to obj hash -- )
to hash maybe-initialize-key
from hash at
[ [ to obj ] dip push-at ]
[ to 1vector obj associate from hash set-at ] if* ;
: add-transition ( from to obj transition-table -- )
- transitions>> set-transition ;
+ transitions>> (add-transition) ;