basis/regexp/dfa/dfa.factor

   1 ! Copyright (C) 2008 Doug Coleman.
   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 ;
   6 USING: io prettyprint threads ;
   7 IN: regexp.dfa
   8
   9 : (while-changes) ( obj quot: ( obj -- obj' ) pred: ( obj -- <=> ) pred-ret -- obj )
  10     [ [ dup slip ] dip pick over call ] dip dupd =
  11     [ 3drop ] [ (while-changes) ] if ; inline recursive
  12
  13 : while-changes ( obj quot pred -- obj' )
  14     3dup nip call (while-changes) ; inline
  15
  16 : find-delta ( states transition nfa -- new-states )
  17     transitions>> '[ _ swap _ at at ] gather sift ;
  18
  19 : (find-epsilon-closure) ( states nfa -- new-states )
  20     eps swap find-delta ;
  21
  22 : find-epsilon-closure ( states nfa -- new-states )
  23     '[ dup _ (find-epsilon-closure) union ] [ length ] while-changes
  24     natural-sort ;
  25
  26 : find-closure ( states transition nfa -- new-states )
  27     [ find-delta ] keep find-epsilon-closure ;
  28
  29 : find-start-state ( nfa -- state )
  30     [ start-state>> 1vector ] keep find-epsilon-closure ;
  31
  32 : find-transitions ( dfa-state nfa -- next-dfa-state )
  33     transitions>>
  34     '[ _ at keys ] gather
  35     eps swap remove ;
  36
  37 : add-todo-state ( state visited-states new-states -- )
  38     3dup drop key? [ 3drop ] [
  39         [ conjoin ] [ push ] bi-curry* bi
  40     ] if ;
  41
  42 :: new-transitions ( nfa dfa new-states visited-states -- nfa dfa )
  43     new-states [ nfa dfa ] [
  44         pop :> state
  45         state nfa find-transitions
  46         [| trans |
  47             state trans nfa find-closure :> new-state
  48             new-state visited-states new-states add-todo-state
  49             state new-state trans transition make-transition dfa add-transition
  50         ] each
  51         nfa dfa new-states visited-states new-transitions
  52     ] if-empty ;
  53
  54 : states ( hashtable -- array )
  55     [ keys ]
  56     [ values [ values concat ] map concat append ] bi ;
  57
  58 : set-final-states ( nfa dfa -- )
  59     [
  60         [ final-states>> keys ]
  61         [ transitions>> states ] bi*
  62         [ intersects? ] with filter
  63     ] [ final-states>> ] bi
  64     [ conjoin ] curry each ;
  65
  66 : initialize-dfa ( nfa -- dfa )
  67     <transition-table>
  68         swap find-start-state >>start-state ;
  69
  70 : construct-dfa ( nfa -- dfa )
  71     dup initialize-dfa
  72     dup start-state>> 1vector
  73     H{ } clone
  74     new-transitions
  75     [ set-final-states ] keep ;