basis/regexp/dfa/dfa.factor

   1 ! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs combinators fry kernel locals
   4 math math.order regexp.nfa regexp.transition-tables sequences
   5 sets sorting vectors sequences.deep math.functions regexp.classes ;
   6 USING: io prettyprint threads ;
   7 IN: regexp.dfa
   8
   9 :: (while-changes) ( obj quot: ( obj -- obj' ) comp: ( obj -- key ) old-key -- obj )
  10     obj quot call :> new-obj
  11     new-obj comp call :> new-key
  12     new-key old-key =
  13     [ new-obj ]
  14     [ new-obj quot comp new-key (while-changes) ]
  15     if ; inline recursive
  16
  17 : while-changes ( obj quot pred -- obj' )
  18     3dup nip call (while-changes) ; inline
  19
  20 TUPLE: parts in out ;
  21
  22 : make-partition ( choices classes -- partition )
  23     zip [ first ] partition parts boa ;
  24
  25 : powerset-partition ( classes -- partitions )
  26     ! Here is where class algebra will happen, when I implement it
  27     [ length [ 2^ ] keep ] keep '[
  28         _ [ ] map-bits _ make-partition
  29     ] map ;
  30
  31 : partition>class ( parts -- class )
  32     [ in>> ] [ out>> ] bi
  33     [ <or-class> ] bi@ <not-class> 2array <and-class> ;
  34
  35 : get-transitions ( partition state-transitions -- next-states )
  36     [ in>> ] dip '[ at ] gather ;
  37
  38 : disambiguate-overlap ( nfa -- nfa' )
  39     [
  40         [
  41             [ keys powerset-partition ] keep '[
  42                 [ partition>class ]
  43                 [ _ get-transitions ] bi
  44             ] H{ } map>assoc
  45         ] assoc-map
  46     ] change-transitions ;
  47
  48 : find-delta ( states transition nfa -- new-states )
  49     transitions>> '[ _ swap _ at at ] gather sift ;
  50
  51 : (find-epsilon-closure) ( states nfa -- new-states )
  52     eps swap find-delta ;
  53
  54 : find-epsilon-closure ( states nfa -- new-states )
  55     '[ dup _ (find-epsilon-closure) union ] [ length ] while-changes
  56     natural-sort ;
  57
  58 : find-closure ( states transition nfa -- new-states )
  59     [ find-delta ] keep find-epsilon-closure ;
  60
  61 : find-start-state ( nfa -- state )
  62     [ start-state>> 1vector ] keep find-epsilon-closure ;
  63
  64 : find-transitions ( dfa-state nfa -- next-dfa-state )
  65     transitions>>
  66     '[ _ at keys ] gather
  67     eps swap remove ;
  68
  69 : add-todo-state ( state visited-states new-states -- )
  70     3dup drop key? [ 3drop ] [
  71         [ conjoin ] [ push ] bi-curry* bi
  72     ] if ;
  73
  74 :: new-transitions ( nfa dfa new-states visited-states -- nfa dfa )
  75     new-states [ nfa dfa ] [
  76         pop :> state
  77         state nfa find-transitions
  78         [| trans |
  79             state trans nfa find-closure :> new-state
  80             new-state visited-states new-states add-todo-state
  81             state new-state trans transition make-transition dfa add-transition
  82         ] each
  83         nfa dfa new-states visited-states new-transitions
  84     ] if-empty ;
  85
  86 : states ( hashtable -- array )
  87     [ keys ]
  88     [ values [ values concat ] map concat append ] bi ;
  89
  90 : set-final-states ( nfa dfa -- )
  91     [
  92         [ final-states>> keys ]
  93         [ transitions>> states ] bi*
  94         [ intersects? ] with filter
  95     ] [ final-states>> ] bi
  96     [ conjoin ] curry each ;
  97
  98 : initialize-dfa ( nfa -- dfa )
  99     <transition-table>
 100         swap find-start-state >>start-state ;
 101
 102 : construct-dfa ( nfa -- dfa )
 103     disambiguate-overlap
 104     dup initialize-dfa
 105     dup start-state>> 1vector
 106     H{ } clone
 107     new-transitions
 108     [ set-final-states ] keep ;