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             >r swapd transition make-transition r> dfa-table>> add-transition
  47         ] curry with each
  48         new-transitions
  49     ] if-empty ;
  50
  51 : states ( hashtable -- array )
  52     [ keys ]
  53     [ values [ values concat ] map concat append ] bi ;
  54
  55 : set-final-states ( regexp -- )
  56     dup
  57     [ nfa-table>> final-states>> keys ]
  58     [ dfa-table>> transitions>> states ] bi
  59     [ intersect empty? not ] with filter
  60
  61     swap dfa-table>> final-states>>
  62     [ conjoin ] curry each ;
  63
  64 : set-initial-state ( regexp -- )
  65     dup
  66     [ dfa-table>> ] [ find-start-state ] bi
  67     [ >>start-state drop ] keep
  68     1vector >>new-states drop ;
  69
  70 : set-traversal-flags ( regexp -- )
  71     dup
  72     [ nfa-traversal-flags>> ]
  73     [ dfa-table>> transitions>> keys ] bi
  74     [ tuck [ swap at ] with map concat ] with H{ } map>assoc
  75     >>dfa-traversal-flags drop ;
  76
  77 : construct-dfa ( regexp -- )
  78     {
  79         [ set-initial-state ]
  80         [ new-transitions ]
  81         [ set-final-states ]
  82         [ set-traversal-flags ]
  83     } cleave ;