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 ] dip over ] dip
  29     '[ _ _ t epsilon-loop ] each ;
  30
  31 : find-epsilon-closure ( states nfa -- dfa-state )
  32     epsilon-table 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 [ condition-states ] map concat ] gather
  43     [ tagged-epsilon? not ] filter ;
  44
  45 : add-todo-state ( state visited-states new-states -- )
  46     2over ?adjoin [ nip push ] [ 3drop ] if ;
  47
  48 : add-todo-states ( state/condition visited-states new-states -- )
  49     [ condition-states ] 2dip
  50     '[ _ _ add-todo-state ] each ;
  51
  52 : ensure-state ( key table -- )
  53     2dup key? [ 2drop ] [ [ H{ } clone ] 2dip set-at ] if ; inline
  54
  55 :: new-transitions ( nfa dfa new-states visited-states -- nfa dfa )
  56     new-states [ nfa dfa ] [
  57         pop :> state
  58         state dfa transitions>> ensure-state
  59         state nfa find-transitions
  60         [| trans |
  61             state trans nfa find-closure :> new-state
  62             new-state visited-states new-states add-todo-states
  63             state new-state trans dfa set-transition
  64         ] each
  65         nfa dfa new-states visited-states new-transitions
  66     ] if-empty ;
  67
  68 : set-final-states ( nfa dfa -- )
  69     [
  70         [ final-states>> members ]
  71         [ transitions>> keys ] bi*
  72         [ intersects? ] with filter
  73         fast-set
  74     ] keep final-states<< ;
  75
  76 : initialize-dfa ( nfa -- dfa )
  77     <transition-table>
  78         swap find-start-state >>start-state ;
  79
  80 : construct-dfa ( nfa -- dfa )
  81     dup initialize-dfa
  82     dup start-state>> condition-states >vector
  83     HS{ } clone
  84     new-transitions
  85     [ set-final-states ] keep ;