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