;; The Rabin-Karp string-matching algorithm

;; John David Stone
;; Department of Mathematics and Computer Science
;; Grinnell College
;; stone@cs.grinnell.edu

;; created November 21, 1999
;; last revised November 20, 2000

(define (Rabin-Karp-matcher text pattern)
  (let ((pattern-length (string-length pattern))
        (text-length (string-length text)))
    (if (< text-length pattern-length)
        (set)
        (let* ((radix 128)
               (modulus 4194301)
               (bump (lambda (multiplicand addend)
                       (modulo (+ (* multiplicand radix) addend)
                               modulus)))
               (char-code (pipe string-ref char->integer))
               (encoder (lambda (str)
                          (lower-ply-natural
                            pattern-length
                            (lambda (index val)
                              (bump val (char-code str index)))
                            0)))
               (pattern-code (encoder pattern))
               (high-place-value
                 (fold-natural (max 0 (predecessor pattern-length))
                               (next-section bump 0)
                               1))
               (dip (tweak-next (next-section * high-place-value)
                                -))
               (advancer
                (lambda (code index)
                  (if (or (zero? pattern-length)
                          (<= text-length
                              (+ index pattern-length))) 
                      0
                      (bump (dip code (char-code text index))
                            (char-code text (+ index pattern-length))))))
               (text-segment
                (lambda (shift)
                  (substring text shift (+ shift pattern-length))))
               (match-found?
                (lambda (shift segment-code)
                  (and (= pattern-code segment-code)
                       (string=? pattern (text-segment shift))))))
          (receive (all-valid-shifts ignored)
                   (lower-ply-natural
                     (successor (- text-length pattern-length))
                     (lambda (shift valid-shifts segment-code)
                       (values (if (match-found? shift segment-code)
                                   (adjoin-to-set shift valid-shifts)
                                   valid-shifts)
                               (advancer segment-code shift)))
                     (set)
                     (encoder text))
            all-valid-shifts)))))