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