basis/regexp/nfa/nfa.factor

   1 ! Copyright (C) 2008 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs grouping kernel
   4 locals math namespaces sequences fry quotations
   5 math.order math.ranges vectors unicode.categories
   6 regexp.transition-tables words sets
   7 unicode.case.private regexp.ast regexp.classes ;
   8 ! This uses unicode.case.private for ch>upper and ch>lower
   9 ! but case-insensitive matching should be done by case-folding everything
  10 ! before processing starts
  11 IN: regexp.nfa
  12
  13 ERROR: feature-is-broken feature ;
  14
  15 SYMBOL: negated?
  16
  17 : negate ( -- )
  18     negated? [ not ] change ;
  19
  20 SINGLETON: eps
  21
  22 SYMBOL: option-stack
  23
  24 SYMBOL: combine-stack
  25
  26 SYMBOL: state
  27
  28 : next-state ( -- state )
  29     state [ get ] [ inc ] bi ;
  30
  31 SYMBOL: nfa-table
  32
  33 : set-each ( keys value hashtable -- )
  34     '[ _ swap _ set-at ] each ;
  35
  36 : options>hash ( options -- hashtable )
  37     H{ } clone [
  38         [ [ on>> t ] dip set-each ]
  39         [ [ off>> f ] dip set-each ] 2bi
  40     ] keep ;
  41
  42 : using-options ( options quot -- )
  43     [ options>hash option-stack [ ?push ] change ] dip
  44     call option-stack get pop* ; inline
  45
  46 : option? ( obj -- ? )
  47     option-stack get assoc-stack ;
  48
  49 : set-start-state ( -- nfa-table )
  50     nfa-table get
  51         combine-stack get pop first >>start-state ;
  52
  53 GENERIC: nfa-node ( node -- )
  54
  55 :: add-simple-entry ( obj class -- )
  56     [let* | s0 [ next-state ]
  57             s1 [ next-state ]
  58             stack [ combine-stack get ]
  59             table [ nfa-table get ] |
  60         negated? get [
  61             s0 f obj class make-transition table add-transition
  62             s0 s1 <default-transition> table add-transition
  63         ] [
  64             s0 s1 obj class make-transition table add-transition
  65         ] if
  66         s0 s1 2array stack push
  67         t s1 table final-states>> set-at ] ;
  68
  69 :: concatenate-nodes ( -- )
  70     [let* | stack [ combine-stack get ]
  71             table [ nfa-table get ]
  72             s2 [ stack peek first ]
  73             s3 [ stack pop second ]
  74             s0 [ stack peek first ]
  75             s1 [ stack pop second ] |
  76         s1 s2 eps <literal-transition> table add-transition
  77         s1 table final-states>> delete-at
  78         s0 s3 2array stack push ] ;
  79
  80 :: alternate-nodes ( -- )
  81     [let* | stack [ combine-stack get ]
  82             table [ nfa-table get ]
  83             s2 [ stack peek first ]
  84             s3 [ stack pop second ]
  85             s0 [ stack peek first ]
  86             s1 [ stack pop second ]
  87             s4 [ next-state ]
  88             s5 [ next-state ] |
  89         s4 s0 eps <literal-transition> table add-transition
  90         s4 s2 eps <literal-transition> table add-transition
  91         s1 s5 eps <literal-transition> table add-transition
  92         s3 s5 eps <literal-transition> table add-transition
  93         s1 table final-states>> delete-at
  94         s3 table final-states>> delete-at
  95         t s5 table final-states>> set-at
  96         s4 s5 2array stack push ] ;
  97
  98 M: star nfa-node ( node -- )
  99     term>> nfa-node
 100     [let* | stack [ combine-stack get ]
 101             s0 [ stack peek first ]
 102             s1 [ stack pop second ]
 103             s2 [ next-state ]
 104             s3 [ next-state ]
 105             table [ nfa-table get ] |
 106         s1 table final-states>> delete-at
 107         t s3 table final-states>> set-at
 108         s1 s0 eps <literal-transition> table add-transition
 109         s2 s0 eps <literal-transition> table add-transition
 110         s2 s3 eps <literal-transition> table add-transition
 111         s1 s3 eps <literal-transition> table add-transition
 112         s2 s3 2array stack push ] ;
 113
 114 M: concatenation nfa-node ( node -- )
 115     seq>> [ eps literal-transition add-simple-entry ] [
 116         reversed-regexp option? [ <reversed> ] when
 117         [ [ nfa-node ] each ]
 118         [ length 1- [ concatenate-nodes ] times ] bi
 119     ] if-empty ;
 120
 121 M: alternation nfa-node ( node -- )
 122     seq>>
 123     [ [ nfa-node ] each ]
 124     [ length 1- [ alternate-nodes ] times ] bi ;
 125
 126 M: integer nfa-node ( node -- )
 127     case-insensitive option? [
 128         dup [ ch>lower ] [ ch>upper ] bi
 129         2dup = [
 130             2drop
 131             literal-transition add-simple-entry
 132         ] [
 133             [ literal-transition add-simple-entry ] bi@
 134             alternate-nodes drop
 135         ] if
 136     ] [
 137         literal-transition add-simple-entry
 138     ] if ;
 139
 140 M: primitive-class nfa-node ( node -- )
 141     class>> dup
 142     { letter-class LETTER-class } member? case-insensitive option? and
 143     [ drop Letter-class ] when
 144     class-transition add-simple-entry ;
 145
 146 M: any-char nfa-node ( node -- )
 147     [ dotall option? ] dip any-char-no-nl ?
 148     class-transition add-simple-entry ;
 149
 150 M: negation nfa-node ( node -- )
 151     negate term>> nfa-node negate ;
 152
 153 M: range nfa-node ( node -- )
 154     case-insensitive option? [
 155         ! This should be implemented for Unicode by case-folding
 156         ! the input and all strings in the regexp.
 157         dup [ from>> ] [ to>> ] bi
 158         2dup [ Letter? ] bi@ and [
 159             rot drop
 160             [ [ ch>lower ] bi@ <range> ]
 161             [ [ ch>upper ] bi@ <range> ] 2bi
 162             [ class-transition add-simple-entry ] bi@
 163             alternate-nodes
 164         ] [
 165             2drop
 166             class-transition add-simple-entry
 167         ] if
 168     ] [
 169         class-transition add-simple-entry
 170     ] if ;
 171
 172 M: with-options nfa-node ( node -- )
 173     dup options>> [ tree>> nfa-node ] using-options ;
 174
 175 : construct-nfa ( ast -- nfa-table )
 176     [
 177         negated? off
 178         V{ } clone combine-stack set
 179         0 state set
 180         <transition-table> clone nfa-table set
 181         nfa-node
 182         set-start-state
 183     ] with-scope ;