basis/regexp/nfa/nfa.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 grouping kernel locals math namespaces
   4 sequences fry quotations math.order math.ranges vectors
   5 unicode.categories regexp.transition-tables words sets hashtables
   6 combinators.short-circuit unicode.data regexp.ast
   7 regexp.classes memoize ;
   8 FROM: namespaces => set ;
   9 IN: regexp.nfa
  10
  11 ! This uses unicode.data for ch>upper and ch>lower
  12 ! but case-insensitive matching should be done by case-folding everything
  13 ! before processing starts
  14
  15 SYMBOL: option-stack
  16
  17 SYMBOL: state
  18
  19 : next-state ( -- state )
  20     state [ get ] [ inc ] bi ;
  21
  22 SYMBOL: nfa-table
  23
  24 : set-each ( keys value hashtable -- )
  25     '[ _ swap _ set-at ] each ;
  26
  27 : options>hash ( options -- hashtable )
  28     H{ } clone [
  29         [ [ on>> t ] dip set-each ]
  30         [ [ off>> f ] dip set-each ] 2bi
  31     ] keep ;
  32
  33 : using-options ( options quot -- )
  34     [ options>hash option-stack [ ?push ] change ] dip
  35     call option-stack get pop* ; inline
  36
  37 : option? ( obj -- ? )
  38     option-stack get assoc-stack ;
  39
  40 GENERIC: nfa-node ( node -- start-state end-state )
  41
  42 : add-simple-entry ( obj -- start-state end-state )
  43     [ next-state next-state 2dup ] dip
  44     nfa-table get add-transition ;
  45
  46 : epsilon-transition ( source target -- )
  47     epsilon nfa-table get add-transition ;
  48
  49 M:: star nfa-node ( node -- start end )
  50     node term>> nfa-node :> ( s0 s1 )
  51     next-state :> s2
  52     next-state :> s3
  53     s1 s0 epsilon-transition
  54     s2 s0 epsilon-transition
  55     s2 s3 epsilon-transition
  56     s1 s3 epsilon-transition
  57     s2 s3 ;
  58
  59 GENERIC: modify-epsilon ( tag -- newtag )
  60 ! Potential off-by-one errors when lookaround nested in lookbehind
  61
  62 M: object modify-epsilon ;
  63
  64 : line-option ( multiline unix-lines default -- option )
  65     multiline option? [
  66         drop [ unix-lines option? ] 2dip swap ?
  67     ] [ 2nip ] if ;
  68
  69 M: $ modify-epsilon
  70     $unix end-of-input line-option ;
  71
  72 M: ^ modify-epsilon
  73     ^unix beginning-of-input line-option ;
  74
  75 M: tagged-epsilon nfa-node
  76     clone [ modify-epsilon ] change-tag add-simple-entry ;
  77
  78 M: concatenation nfa-node ( node -- start end )
  79     [ first>> ] [ second>> ] bi
  80     reversed-regexp option? [ swap ] when
  81     [ nfa-node ] bi@
  82     [ epsilon-transition ] dip ;
  83
  84 :: alternate-nodes ( s0 s1 s2 s3 -- start end )
  85     next-state :> s4
  86     next-state :> s5
  87     s4 s0 epsilon-transition
  88     s4 s2 epsilon-transition
  89     s1 s5 epsilon-transition
  90     s3 s5 epsilon-transition
  91     s4 s5 ;
  92
  93 M: alternation nfa-node ( node -- start end )
  94     [ first>> ] [ second>> ] bi
  95     [ nfa-node ] bi@
  96     alternate-nodes ;
  97
  98 GENERIC: modify-class ( char-class -- char-class' )
  99
 100 M: object modify-class ;
 101
 102 M: integer modify-class
 103     case-insensitive option? [
 104         dup Letter? [
 105             [ ch>lower ] [ ch>upper ] bi 2array <or-class>
 106         ] when
 107     ] when ;
 108
 109 M: integer nfa-node ( node -- start end )
 110     modify-class add-simple-entry ;
 111
 112 M: primitive-class modify-class
 113     class>> modify-class <primitive-class> ;
 114
 115 M: or-class modify-class
 116     seq>> [ modify-class ] map <or-class> ;
 117
 118 M: not-class modify-class
 119     class>> modify-class <not-class> ;
 120
 121 MEMO: unix-dot ( -- class )
 122     CHAR: \n <not-class> ;
 123
 124 MEMO: nonl-dot ( -- class )
 125     { CHAR: \n CHAR: \r } <or-class> <not-class> ;
 126
 127 M: dot modify-class
 128     drop dotall option? [ t ] [
 129         unix-lines option?
 130         unix-dot nonl-dot ?
 131     ] if ;
 132
 133 : modify-letter-class ( class -- newclass )
 134     case-insensitive option? [ drop Letter-class ] when ;
 135 M: letter-class modify-class modify-letter-class ;
 136 M: LETTER-class modify-class modify-letter-class ;
 137
 138 : cased-range? ( range -- ? )
 139     [ from>> ] [ to>> ] bi {
 140         [ [ letter? ] both? ]
 141         [ [ LETTER? ] both? ]
 142     } 2|| ;
 143
 144 M: range-class modify-class
 145     case-insensitive option? [
 146         dup cased-range? [
 147             [ from>> ] [ to>> ] bi
 148             [ [ ch>lower ] bi@ <range-class> ]
 149             [ [ ch>upper ] bi@ <range-class> ] 2bi
 150             2array <or-class>
 151         ] when
 152     ] when ;
 153
 154 M: object nfa-node
 155     modify-class add-simple-entry ;
 156
 157 M: with-options nfa-node ( node -- start end )
 158     dup options>> [ tree>> nfa-node ] using-options ;
 159
 160 : construct-nfa ( ast -- nfa-table )
 161     [
 162         0 state set
 163         <transition-table> nfa-table set
 164         nfa-node
 165         nfa-table get
 166             swap 1array fast-set >>final-states
 167             swap >>start-state
 168     ] with-scope ;