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