basis/regexp/dfa/dfa.factor

   1 ! Copyright (C) 2008 Doug Coleman.
   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.utils sequences.deep ;
   6 USING: io prettyprint threads ;
   7 IN: regexp.dfa
   8
   9 : find-delta ( states transition regexp -- new-states )
  10     nfa-table>> transitions>>
  11     rot [ swap at at ] with with gather sift ;
  12
  13 : (find-epsilon-closure) ( states regexp -- new-states )
  14     eps swap find-delta ;
  15
  16 : find-epsilon-closure ( states regexp -- new-states )
  17     '[ dup _ (find-epsilon-closure) union ] [ length ] while-changes
  18     natural-sort ;
  19
  20 : find-closure ( states transition regexp -- new-states )
  21     [ find-delta ] 2keep nip find-epsilon-closure ;
  22
  23 : find-start-state ( regexp -- state )
  24     [ nfa-table>> start-state>> 1vector ] keep find-epsilon-closure ;
  25
  26 : find-transitions ( seq1 regexp -- seq2 )
  27     nfa-table>> transitions>>
  28     [ at keys ] curry gather
  29     eps swap remove ;
  30
  31 : add-todo-state ( state regexp -- )
  32     2dup visited-states>> key? [
  33         2drop
  34     ] [
  35         [ visited-states>> conjoin ]
  36         [ new-states>> push ] 2bi
  37     ] if ;
  38
  39 : new-transitions ( regexp -- )
  40     dup new-states>> [
  41         drop
  42     ] [
  43         dupd pop dup pick find-transitions rot
  44         [
  45             [ [ find-closure ] 2keep nip dupd add-todo-state ] 3keep
  46             [ swapd transition make-transition ] dip
  47             dfa-table>> add-transition
  48         ] curry with each
  49         new-transitions
  50     ] if-empty ;
  51
  52 : states ( hashtable -- array )
  53     [ keys ]
  54     [ values [ values concat ] map concat append ] bi ;
  55
  56 : set-final-states ( regexp -- )
  57     dup
  58     [ nfa-table>> final-states>> keys ]
  59     [ dfa-table>> transitions>> states ] bi
  60     [ intersects? ] with filter
  61
  62     swap dfa-table>> final-states>>
  63     [ conjoin ] curry each ;
  64
  65 : set-initial-state ( regexp -- )
  66     dup
  67     [ dfa-table>> ] [ find-start-state ] bi
  68     [ >>start-state drop ] keep
  69     1vector >>new-states drop ;
  70
  71 : set-traversal-flags ( regexp -- )
  72     dup
  73     [ nfa-traversal-flags>> ]
  74     [ dfa-table>> transitions>> keys ] bi
  75     [ tuck [ swap at ] with map concat ] with H{ } map>assoc
  76     >>dfa-traversal-flags drop ;
  77
  78 : construct-dfa ( regexp -- )
  79     {
  80         [ set-initial-state ]
  81         [ new-transitions ]
  82         [ set-final-states ]
  83         [ set-traversal-flags ]
  84     } cleave ;