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 hashtables
   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 SYMBOL: negated?
  14
  15 : negate ( -- )
  16     negated? [ not ] change ;
  17
  18 SINGLETON: eps
  19
  20 SYMBOL: option-stack
  21
  22 SYMBOL: state
  23
  24 : next-state ( -- state )
  25     state [ get ] [ inc ] bi ;
  26
  27 SYMBOL: nfa-table
  28 : table ( -- table ) nfa-table get ;
  29
  30 : set-each ( keys value hashtable -- )
  31     '[ _ swap _ set-at ] each ;
  32
  33 : options>hash ( options -- hashtable )
  34     H{ } clone [
  35         [ [ on>> t ] dip set-each ]
  36         [ [ off>> f ] dip set-each ] 2bi
  37     ] keep ;
  38
  39 : using-options ( options quot -- )
  40     [ options>hash option-stack [ ?push ] change ] dip
  41     call option-stack get pop* ; inline
  42
  43 : option? ( obj -- ? )
  44     option-stack get assoc-stack ;
  45
  46 GENERIC: nfa-node ( node -- start-state end-state )
  47
  48 :: add-simple-entry ( obj class -- start-state end-state )
  49     next-state :> s0
  50     next-state :> s1
  51     negated? get [
  52         s0 f obj class make-transition table add-transition
  53         s0 s1 <default-transition> table add-transition
  54     ] [
  55         s0 s1 obj class make-transition table add-transition
  56     ] if
  57     s0 s1 ;
  58
  59 : epsilon-transition ( source target -- )
  60     eps <literal-transition> table add-transition ;
  61
  62 M:: star nfa-node ( node -- start end )
  63     node term>> nfa-node :> s1 :> s0
  64     next-state :> s2
  65     next-state :> s3
  66     s1 s0 epsilon-transition
  67     s2 s0 epsilon-transition
  68     s2 s3 epsilon-transition
  69     s1 s3 epsilon-transition
  70     s2 s3 ;
  71
  72 M: epsilon nfa-node
  73     drop eps literal-transition add-simple-entry ;
  74
  75 M: concatenation nfa-node ( node -- start end )
  76     [ first>> ] [ second>> ] bi
  77     reversed-regexp option? [ swap ] when
  78     [ nfa-node ] bi@
  79     [ epsilon-transition ] dip ;
  80
  81 :: alternate-nodes ( s0 s1 s2 s3 -- start end )
  82     next-state :> s4
  83     next-state :> s5
  84     s4 s0 epsilon-transition
  85     s4 s2 epsilon-transition
  86     s1 s5 epsilon-transition
  87     s3 s5 epsilon-transition
  88     s4 s5 ;
  89
  90 M: alternation nfa-node ( node -- start end )
  91     [ first>> ] [ second>> ] bi
  92     [ nfa-node ] bi@
  93     alternate-nodes ;
  94
  95 M: integer nfa-node ( node -- start end )
  96     case-insensitive option? [
  97         dup [ ch>lower ] [ ch>upper ] bi
  98         2dup = [
  99             2drop
 100             literal-transition add-simple-entry
 101         ] [
 102             [ literal-transition add-simple-entry ] bi@
 103             alternate-nodes [ nip ] dip
 104         ] if
 105     ] [ literal-transition add-simple-entry ] if ;
 106
 107 M: primitive-class nfa-node ( node -- start end )
 108     class>> dup
 109     { letter-class LETTER-class } member? case-insensitive option? and
 110     [ drop Letter-class ] when
 111     class-transition add-simple-entry ;
 112
 113 M: or-class nfa-node class-transition add-simple-entry ;
 114 M: not-class nfa-node class-transition add-simple-entry ;
 115
 116 M: any-char nfa-node ( node -- start end )
 117     [ dotall option? ] dip any-char-no-nl ?
 118     class-transition add-simple-entry ;
 119
 120 ! M: negation nfa-node ( node -- start end )
 121 !     negate term>> nfa-node negate ;
 122
 123 M: range nfa-node ( node -- start end )
 124     case-insensitive option? [
 125         ! This should be implemented for Unicode by case-folding
 126         ! the input and all strings in the regexp.
 127         dup [ from>> ] [ to>> ] bi
 128         2dup [ Letter? ] bi@ and [
 129             rot drop
 130             [ [ ch>lower ] bi@ <range> ]
 131             [ [ ch>upper ] bi@ <range> ] 2bi
 132             [ class-transition add-simple-entry ] bi@
 133             alternate-nodes
 134         ] [
 135             2drop
 136             class-transition add-simple-entry
 137         ] if
 138     ] [
 139         class-transition add-simple-entry
 140     ] if ;
 141
 142 M: with-options nfa-node ( node -- start end )
 143     dup options>> [ tree>> nfa-node ] using-options ;
 144
 145 : construct-nfa ( ast -- nfa-table )
 146     [
 147         negated? off
 148         0 state set
 149         <transition-table> clone nfa-table set
 150         nfa-node
 151         table
 152             swap dup associate >>final-states
 153             swap >>start-state
 154     ] with-scope ;