sunet/stringhax.scm

90 lines
2.4 KiB
Scheme

;;; 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-invert 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)))))