extra/boyer-moore/boyer-moore.factor

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