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