1 ! Copyright (C) 2010 Dmitry Shubin.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs kernel math math.order ranges
4 sequences sequences.private z-algorithm ;
9 :: (normal-suffixes) ( i zs ss -- )
11 [ [ i ] unless* ] change-nth-unsafe ; inline
13 : normal-suffixes ( zs -- ss )
14 [ length [ f <array> ] [ [1..b) ] bi ] keep pick
15 [ (normal-suffixes) ] 2curry each ; inline
17 :: (partial-suffixes) ( len old elt i -- len old/new old )
18 len elt i 1 + = [ len elt - ] [ old ] if old ; inline
20 : partial-suffixes ( zs -- ss )
21 [ length dup ] [ <reversed> ] bi
22 [ (partial-suffixes) ] map-index 2nip ; inline
24 : <good-suffix-table> ( seq -- table )
25 z-values [ partial-suffixes ] [ normal-suffixes ] bi
26 [ [ nip ] when* ] 2map reverse! ; inline
28 : insert-bad-char-shift ( table elt len i -- table )
29 1 + swap - swap pick 2dup key?
30 [ 3drop ] [ set-at ] if ; inline
32 : <bad-char-table> ( seq -- table )
33 H{ } clone swap [ length ] keep
34 [ insert-bad-char-shift ] with each-index ; inline
36 TUPLE: boyer-moore pattern bad-char-table good-suffix-table ;
38 : good-suffix-shift ( i c boyer-moore -- s ) nip good-suffix-table>> nth-unsafe ; inline
40 : bad-char-shift ( i c boyer-moore -- s ) bad-char-table>> at dup 1 ? + ; inline
42 : do-shift ( pos i c boyer-moore -- newpos )
43 [ good-suffix-shift ] [ bad-char-shift ] bi-curry 2bi max + ; inline
45 : match? ( i1 s1 i2 s2 -- ? ) [ nth-unsafe ] 2bi@ = ; inline
47 :: mismatch? ( s1 s2 pos len -- i/f )
48 len 1 - [ [ pos + s1 ] keep s2 match? not ]
49 find-last-integer-from ; inline
51 :: (search-from) ( seq from boyer-moore -- i/f )
52 boyer-moore pattern>> :> pat
54 seq length plen - :> lim
59 seq pat pick plen mismatch?
60 [ 2dup + seq nth-unsafe boyer-moore do-shift t ] [ f ] if*
66 : <boyer-moore> ( pattern -- boyer-moore )
67 dup <reversed> [ <bad-char-table> ] [ <good-suffix-table> ] bi
70 GENERIC: search-from ( seq from obj -- i/f )
72 M: sequence search-from
73 [ 2drop 0 ] [ <boyer-moore> (search-from) ] if-empty ;
75 M: boyer-moore search-from (search-from) ;
77 : search ( seq obj -- i/f ) [ 0 ] dip search-from ;