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