module/slib/strsrch.scm

   1 ;;; "MISCIO" Search for string from port.
   2 ; Written 1995, 1996 by Oleg Kiselyov (oleg@ponder.csci.unt.edu)
   3 ; Modified 1996, 1997, 1998 by A. Jaffer (jaffer@ai.mit.edu)
   4 ;
   5 ; This code is in the public domain.
   6
   7 ;;; Return the index of the first occurence of a-char in str, or #f
   8 (define (string-index str a-char)
   9   (let loop ((pos 0))
  10     (cond
  11      ;; whole string has been searched, in vain
  12      ((>= pos (string-length str)) #f)
  13      ((char=? a-char (string-ref str pos)) pos)
  14      (else (loop (+ 1 pos))))))
  15
  16 (define (string-index-ci str a-char)
  17   (let loop ((pos 0))
  18     (cond
  19      ;; whole string has been searched, in vain
  20      ((>= pos (string-length str)) #f)
  21      ((char-ci=? a-char (string-ref str pos)) pos)
  22      (else (loop (+ 1 pos))))))
  23
  24 (define (string-reverse-index str a-char)
  25   (let loop ((pos (- (string-length str) 1)))
  26     (cond ((< pos 0) #f)
  27           ((char=? (string-ref str pos) a-char) pos)
  28           (else (loop (- pos 1))))))
  29
  30 (define (string-reverse-index-ci str a-char)
  31   (let loop ((pos (- (string-length str) 1)))
  32     (cond ((< pos 0) #f)
  33           ((char-ci=? (string-ref str pos) a-char) pos)
  34           (else (loop (- pos 1))))))
  35
  36 (define (miscio:substring? pattern str char=?)
  37   (let* ((pat-len (string-length pattern))
  38          (search-span (- (string-length str) pat-len))
  39          (c1 (if (zero? pat-len) #f (string-ref pattern 0)))
  40          (c2 (if (<= pat-len 1) #f (string-ref pattern 1))))
  41     (cond
  42      ((not c1) 0)                       ; empty pattern, matches upfront
  43      ((not c2) (string-index str c1))   ; one-char pattern
  44      (else                              ; matching pattern of > two chars
  45       (let outer ((pos 0))
  46         (cond
  47          ((> pos search-span) #f)       ; nothing was found thru the whole str
  48          ((not (char=? c1 (string-ref str pos)))
  49           (outer (+ 1 pos)))            ; keep looking for the right beginning
  50          ((not (char=? c2 (string-ref str (+ 1 pos))))
  51           (outer (+ 1 pos)))            ; could've done pos+2 if c1 == c2....
  52          (else                          ; two char matched: high probability
  53                                         ; the rest will match too
  54           (let inner ((i-pat 2) (i-str (+ 2 pos)))
  55             (if (>= i-pat pat-len) pos  ; the whole pattern matched
  56                 (if (char=? (string-ref pattern i-pat)
  57                             (string-ref str i-str))
  58                     (inner (+ 1 i-pat) (+ 1 i-str))
  59                     ;; mismatch after partial match
  60                     (outer (+ 1 pos))))))))))))
  61
  62 (define (substring? pattern str) (miscio:substring? pattern str char=?))
  63 (define (substring-ci? pattern str) (miscio:substring? pattern str char-ci=?))
  64
  65 (define (find-string-from-port? str <input-port> . max-no-char)
  66   (set! max-no-char (if (null? max-no-char) #f (car max-no-char)))
  67   (letrec
  68       ((no-chars-read 0)
  69        (peeked? #f)
  70        (my-peek-char                    ; Return a peeked char or #f
  71         (lambda () (and (or (not (number? max-no-char))
  72                             (< no-chars-read max-no-char))
  73                         (let ((c (peek-char <input-port>)))
  74                           (cond (peeked? c)
  75                                 ((eof-object? c) #f)
  76                                 ((procedure? max-no-char)
  77                                  (set! peeked? #t)
  78                                  (if (max-no-char c) #f c))
  79                                 ((eqv? max-no-char c) #f)
  80                                 (else c))))))
  81        (next-char (lambda () (set! peeked? #f) (read-char <input-port>)
  82                           (set! no-chars-read  (+ 1 no-chars-read))))
  83        (match-1st-char                  ; of the string str
  84         (lambda ()
  85           (let ((c (my-peek-char)))
  86             (and c
  87                  (begin (next-char)
  88                         (if (char=? c (string-ref str 0))
  89                             (match-other-chars 1)
  90                             (match-1st-char)))))))
  91        ;; There has been a partial match, up to the point pos-to-match
  92        ;; (for example, str[0] has been found in the stream)
  93        ;; Now look to see if str[pos-to-match] for would be found, too
  94        (match-other-chars
  95         (lambda (pos-to-match)
  96           (if (>= pos-to-match (string-length str))
  97               no-chars-read             ; the entire string has matched
  98               (let ((c (my-peek-char)))
  99                 (and c
 100                      (if (not (char=? c (string-ref str pos-to-match)))
 101                          (backtrack 1 pos-to-match)
 102                          (begin (next-char)
 103                                 (match-other-chars (+ 1 pos-to-match)))))))))
 104
 105        ;; There had been a partial match, but then a wrong char showed up.
 106        ;; Before discarding previously read (and matched) characters, we check
 107        ;; to see if there was some smaller partial match. Note, characters read
 108        ;; so far (which matter) are those of str[0..matched-substr-len - 1]
 109        ;; In other words, we will check to see if there is such i>0 that
 110        ;; substr(str,0,j) = substr(str,i,matched-substr-len)
 111        ;; where j=matched-substr-len - i
 112        (backtrack
 113         (lambda (i matched-substr-len)
 114           (let ((j (- matched-substr-len i)))
 115             (if (<= j 0)
 116                 ;; backed off completely to the begining of str
 117                 (match-1st-char)
 118                 (let loop ((k 0))
 119                   (if (>= k j)
 120                       (match-other-chars j) ; there was indeed a shorter match
 121                       (if (char=? (string-ref str k)
 122                                   (string-ref str (+ i k)))
 123                           (loop (+ 1 k))
 124                           (backtrack (+ 1 i) matched-substr-len))))))))
 125        )
 126     (match-1st-char)))
 127
 128 (define (string-subst text old new . rest)
 129   (define sub
 130     (lambda (text)
 131       (set! text
 132             (cond ((equal? "" text) text)
 133                   ((substring? old text)
 134                    => (lambda (idx)
 135                         (string-append
 136                          (substring text 0 idx)
 137                          new
 138                          (sub (substring
 139                                text (+ idx (string-length old))
 140                                (string-length text))))))
 141                   (else text)))
 142       (if (null? rest)
 143           text
 144           (apply string-subst text rest))))
 145   (sub text))
 146