sunet/stringhax.scm

;;; Random string-hacking procs -*- Scheme -*-
;;; Copyright (c) 1995 by Olin Shivers.
;;; Copyright (c) 1997 by Mike Sperber

; do a 'map' on each character of the string
(define (string-map f s)
  (let* ((slen (string-length s))
	 (ns (make-string slen)))
    (do ((i (- slen 1) (- i 1)))
	((< i 0) ns)
      (string-set! ns i (f (string-ref s i))))))

; convert string to down-/uppercase
(define (downcase-string s)
  (string-map char-downcase s))

(define (upcase-string s)
  (string-map char-upcase s))


;return index of first character contained in char-set
(define (char-set-index str cset . maybe-start)
  (let-optionals maybe-start ((start 0))
    (let ((len (string-length str)))
      (do ((i start (+ 1 i)))
	  ((or (>= i len)
	       (char-set-contains? cset (string-ref str i)))
	   (and (< i len) i))))))

;return index of last character contained in char-set
;NOTE: character defined by maybe-start is not looked up
(define (char-set-rindex str cset . maybe-start)
  (let ((len (string-length str)))
    (let-optionals maybe-start ((start len))
      (do ((i (- start 1) (- i 1)))
	  ((or (< i 0)
	       (char-set-contains? cset (string-ref str i)))
	   (and (>= i 0) i))))))

;do a "fold-right" on string
;(string-reduce nil cons s) ==> (cons ... (cons s[1] (cons s[0] nil)) ...)
(define (string-reduce nil cons s)
  (let ((slen (string-length s)))
    (do ((ans nil (cons (string-ref s i) ans))
	 (i 0 (+ i 1)))
	((= i slen) ans))))

;is PREFIX a prefix of STRING?
(define (string-prefix? prefix string)
  (let ((plen (string-length prefix))
	(slen (string-length string)))
    (and (<= plen slen)
	 (let lp ((i 0))
	   (or (= i plen)
	       (and (char=? (string-ref prefix i)
			    (string-ref string i))
		    (lp (+ i 1))))))))

;is SUFFIX a suffix of STRING?
(define (string-suffix? suffix string)
  (let ((slen (string-length suffix))
	(len (string-length string)))
    (and (<= slen len)
	 (let lp ((i (- slen 1))
		  (j (-  len 1)))
	   (or (< i 0)
	       (and (char=? (string-ref suffix i)
			    (string-ref string j))
		    (lp (- i 1) (- j 1))))))))

;return index of first non-whitespace character in S, #f otherwise
(define skip-whitespace
  (let ((non-whitespace (char-set-complement char-set:whitespace)))
    (lambda (s) (char-set-index s non-whitespace))))

; Why is this so complicated?
; Hope, it isn't anymore *g*  Andreas

(define (trim-spaces string)
  (let* ((the-loop 
	  (lambda (start incr)
	    (let lp ((i start))
	      (if (char=? #\space (string-ref string i))
		  (lp (+ i incr))
		  i))))
	 (start (the-loop 0 1))
	 (end (+ 1 (the-loop (- (string-length string) 1) -1))))
    (substring string start end)))