sunet/stringhax.scm

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

(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))))))

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

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


(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))))))

(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))))))

(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))))

(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))))))))

(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))))))))

(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?

(define (trim-spaces string)
  (if (string=? "" string)
      string
      (let* ((length (string-length string))
	     (start
	      (if (not (char=? #\space (string-ref string 0)))
		  0
		  (do ((index 0 (+ 1 index)))
		      ((or (= index length)
			   (not (char=? #\space (string-ref string index))))
		       index))))
	     (end
	      (if (not (char=? #\space (string-ref string (- length 1))))
		  length
		  (do ((index (- length 1) (- index 1)))
		      ((or (= index 0)
			   (not (char=? #\space (string-ref string index))))
		       (+ 1 index))))))
	(if (and (= 0 start)
		 (= length end))
	    string
	    (substring string start end)))))