1 ! Copyright (C) 2009 Daniel Ehrenberg.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors assocs combinators combinators.short-circuit
4 kernel kernel.private math namespaces quotations regexp.classes
5 regexp.transition-tables sequences sequences.private sets
6 strings unicode words ;
9 GENERIC: question>quot ( question -- quot )
16 M: t question>quot drop [ 2drop t ] ;
17 M: f question>quot drop [ 2drop f ] ;
19 M: beginning-of-input question>quot
22 M: end-of-input question>quot
25 M: end-of-file question>quot
28 [ length swap - 2 <= ]
29 [ swap tail { "\n" "\r\n" "\r" "" } member? ]
33 M: $crlf question>quot
34 drop [ { [ length = ] [ ?nth "\r\n" member? ] } 2|| ] ;
36 M: ^crlf question>quot
37 drop [ { [ drop zero? ] [ [ 1 - ] dip ?nth "\r\n" member? ] } 2|| ] ;
39 M: $unix question>quot
40 drop [ { [ length = ] [ ?nth CHAR: \n = ] } 2|| ] ;
42 M: ^unix question>quot
43 drop [ { [ drop zero? ] [ [ 1 - ] dip ?nth CHAR: \n = ] } 2|| ] ;
45 M: word-break question>quot
46 drop [ word-break-at? ] ;
48 : (execution-quot) ( next-state -- quot )
49 ! The conditions here are for lookaround and anchors, etc
51 [ question>> question>quot ] [ yes>> ] [ no>> ] tri
52 [ (execution-quot) ] bi@
56 : execution-quot ( next-state -- quot )
57 dup sequence? [ first ] when
63 : condition>quot ( condition -- quot )
64 ! Conditions here are for different classes
66 [ question>> ] [ yes>> ] [ no>> ] tri
67 [ condition>quot ] bi@
68 '[ dup _ class-member? _ _ if ]
71 [ [ 3drop ] ] [ execution-quot '[ drop @ ] ] if-empty
74 : non-literals>dispatch ( literals non-literals -- quot )
75 [ swap ] assoc-map ! we want state => predicate, and get the opposite as input
76 swap keys f assoc-answers
77 table>condition [ <box> ] condition-map condition>quot ;
79 : literals>cases ( literal-transitions -- case-body )
80 [ execution-quot ] assoc-map ;
82 : split-literals ( transitions -- case default )
83 { } assoc-like [ first integer? ] partition
84 [ [ literals>cases ] keep ] dip non-literals>dispatch ;
86 : advance ( index backwards? -- index+/-1 )
87 -1 1 ? + >fixnum ; inline
89 : check ( index string backwards? -- in-bounds? )
90 [ drop -1 eq? not ] [ length < ] if ; inline
92 :: step ( last-match index str quot final? backwards? -- last-index/f )
93 final? index last-match ?
94 index str backwards? check [
95 index backwards? advance str
100 : transitions>quot ( transitions final-state? -- quot )
101 dup shortest? get and [ 2drop [ drop nip ] ] [
102 [ split-literals swap case>quot ] dip backwards? get
103 '[ { fixnum string } declare _ _ _ step ]
106 : word>quot ( word dfa -- quot )
108 [ final-states>> in? ] 2bi
111 : states>code ( words dfa -- )
114 ( last-match index string -- ? )
118 : states>words ( dfa -- words dfa )
119 dup transitions>> keys [ gensym ] H{ } map>assoc
124 : dfa>main-word ( dfa -- word )
125 states>words [ states>code ] keep start-state>> ;
127 : word-template ( quot -- quot' )
128 '[ drop [ f ] 2dip over array-capacity? _ [ 2drop ] if ] ;
132 : dfa>word ( dfa -- quot )
133 dfa>main-word execution-quot word-template
134 ( start-index string regexp -- i/f ) define-temp ;
136 : dfa>shortest-word ( dfa -- word )
137 t shortest? [ dfa>word ] with-variable ;
139 : dfa>reverse-word ( dfa -- word )
140 t backwards? [ dfa>word ] with-variable ;
142 : dfa>reverse-shortest-word ( dfa -- word )
143 t backwards? [ dfa>shortest-word ] with-variable ;