129 lines
3.8 KiB
Factor
129 lines
3.8 KiB
Factor
! 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.ast regexp.classes ;
|
|
IN: regexp.dfa
|
|
|
|
: find-delta ( states transition nfa -- new-states )
|
|
transitions>> '[ _ swap _ at at ] gather sift ;
|
|
|
|
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 -- 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>> 1array ] keep find-epsilon-closure ;
|
|
|
|
: find-transitions ( dfa-state nfa -- next-dfa-state )
|
|
transitions>>
|
|
'[ _ at keys ] gather
|
|
epsilon swap remove ;
|
|
|
|
: add-todo-state ( state visited-states new-states -- )
|
|
3dup drop key? [ 3drop ] [
|
|
[ conjoin ] [ push ] bi-curry* bi
|
|
] if ;
|
|
|
|
:: new-transitions ( nfa dfa new-states visited-states -- nfa dfa )
|
|
new-states [ nfa dfa ] [
|
|
pop :> 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 dfa set-transition
|
|
] each
|
|
nfa dfa new-states visited-states new-transitions
|
|
] if-empty ;
|
|
|
|
: states ( hashtable -- array )
|
|
[ keys ]
|
|
[ values [ values concat ] map concat ] bi
|
|
append ;
|
|
|
|
: set-final-states ( nfa dfa -- )
|
|
[
|
|
[ final-states>> keys ]
|
|
[ transitions>> states ] bi*
|
|
[ intersects? ] with filter
|
|
] [ final-states>> ] bi
|
|
[ conjoin ] curry each ;
|
|
|
|
: initialize-dfa ( nfa -- dfa )
|
|
<transition-table>
|
|
swap find-start-state >>start-state ;
|
|
|
|
: construct-dfa ( nfa -- dfa )
|
|
dup initialize-dfa
|
|
dup start-state>> 1vector
|
|
H{ } clone
|
|
new-transitions
|
|
[ set-final-states ] keep ;
|