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 combinators.short-circuit
   7 unicode.case.private regexp.ast regexp.classes ;
   8 IN: regexp.nfa
   9
  10 ! This uses unicode.case.private for ch>upper and ch>lower
  11 ! but case-insensitive matching should be done by case-folding everything
  12 ! before processing starts
  13
  14 GENERIC: remove-lookahead ( syntax-tree -- syntax-tree' )
  15 ! This is unfinished and does nothing right now!
  16
  17 M: object remove-lookahead ;
  18
  19 M: with-options remove-lookahead
  20     [ tree>> remove-lookahead ] [ options>> ] bi <with-options> ;
  21
  22 M: alternation remove-lookahead
  23     [ first>> ] [ second>> ] bi [ remove-lookahead ] bi@ alternation boa ;
  24
  25 M: concatenation remove-lookahead ;
  26
  27 SINGLETON: eps
  28
  29 SYMBOL: option-stack
  30
  31 SYMBOL: state
  32
  33 : next-state ( -- state )
  34     state [ get ] [ inc ] bi ;
  35
  36 SYMBOL: nfa-table
  37 : table ( -- table ) nfa-table get ;
  38
  39 : set-each ( keys value hashtable -- )
  40     '[ _ swap _ set-at ] each ;
  41
  42 : options>hash ( options -- hashtable )
  43     H{ } clone [
  44         [ [ on>> t ] dip set-each ]
  45         [ [ off>> f ] dip set-each ] 2bi
  46     ] keep ;
  47
  48 : using-options ( options quot -- )
  49     [ options>hash option-stack [ ?push ] change ] dip
  50     call option-stack get pop* ; inline
  51
  52 : option? ( obj -- ? )
  53     option-stack get assoc-stack ;
  54
  55 GENERIC: nfa-node ( node -- start-state end-state )
  56
  57 : add-simple-entry ( obj class -- start-state end-state )
  58     [ next-state next-state 2dup ] 2dip
  59     make-transition table add-transition ;
  60
  61 : epsilon-transition ( source target -- )
  62     eps <literal-transition> table add-transition ;
  63
  64 M:: star nfa-node ( node -- start end )
  65     node term>> nfa-node :> s1 :> s0
  66     next-state :> s2
  67     next-state :> s3
  68     s1 s0 epsilon-transition
  69     s2 s0 epsilon-transition
  70     s2 s3 epsilon-transition
  71     s1 s3 epsilon-transition
  72     s2 s3 ;
  73
  74 M: epsilon nfa-node
  75     drop eps literal-transition 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 dup class?
 110     class-transition literal-transition ?
 111     add-simple-entry ;
 112
 113 M: primitive-class modify-class
 114     class>> modify-class <primitive-class> ;
 115
 116 M: or-class modify-class
 117     seq>> [ modify-class ] map <or-class> ;
 118
 119 M: not-class modify-class
 120     class>> modify-class <not-class> ;
 121
 122 M: any-char modify-class
 123     drop dotall option? t any-char-no-nl ? ;
 124
 125 : modify-letter-class ( class -- newclass )
 126     case-insensitive option? [ drop Letter-class ] when ;
 127 M: letter-class modify-class modify-letter-class ;
 128 M: LETTER-class modify-class modify-letter-class ;
 129
 130 : cased-range? ( range -- ? )
 131     [ from>> ] [ to>> ] bi {
 132         [ [ letter? ] bi@ and ]
 133         [ [ LETTER? ] bi@ and ]
 134     } 2|| ;
 135
 136 M: range modify-class
 137     case-insensitive option? [
 138         dup cased-range? [
 139             [ from>> ] [ to>> ] bi
 140             [ [ ch>lower ] bi@ <range> ]
 141             [ [ ch>upper ] bi@ <range> ] 2bi
 142             2array <or-class>
 143         ] when
 144     ] when ;
 145
 146 M: class nfa-node
 147     modify-class class-transition add-simple-entry ;
 148
 149 M: with-options nfa-node ( node -- start end )
 150     dup options>> [ tree>> nfa-node ] using-options ;
 151
 152 : construct-nfa ( ast -- nfa-table )
 153     [
 154         0 state set
 155         <transition-table> nfa-table set
 156         remove-lookahead nfa-node
 157         table
 158             swap dup associate >>final-states
 159             swap >>start-state
 160     ] with-scope ;