;;;; -*- Scheme -*-
;;;; $Header: /home/panda/pg/bevan/progs/elk/scm/RCS/string-extensions.scm,v 1.6 91/04/02 19:49:16 bevan Exp $
;;;+c
;;; Various misc. functions that operate on strings.
;;; Ideas from various languages like :- CommonLisp, Icon, Python, Perl ...
;;; The definitions here are written for portability rather than for
;;; speed.  If you really need fast versions, I suggest you re-code in
;;; a low level language like C.
;;;
;;; System : ELK
;;; System Specific Features :-
;;;   provide (as in CommonLisp)
;;;-c

;;;+f
;;; Center the string `s1' in a string of size `width', padding on the
;;; left and right, if necessary with the string `s2'.  If `s2' is not
;;; given, then spaces are used.  If `s1' cannot be centered exactly,
;;; it is placed left of center.  Truncation is then done at the left
;;; and right as necessary.  For example :-
;;;   (string-center "Detroit" 10 "+") == "+Detroit++"
;;;   (string-center "Detroit" 6)      == "Detroi"
;;; Based on the Icon function center(s1, i, s2)
;;; Note this does not do the same thing as the Icon function for the case
;;; where `width' < (string-length s1).  If anybody can explain why the
;;; Icon function produces "etroit" in the second case, I'll be happy to
;;; change it.
;;;-f
(define (string-center s1 width . s2)
  (let ((padding (if s2 (car s2) " "))
	(str-len (string-length s1)))
    (cond ((> width str-len)
	   (let* ((left (quotient (- width str-len) 2))
		  (right (- width (+ left str-len))))
	     (string-append (string-replw padding left)
			    s1
			    (string-replw padding right))))
	  ((< width str-len)
	   (let* ((left (quotient (- str-len width) 2))
		  (right (+ left width)))
	     (substring s1 left right)))
	  (else s1))))
  
;;; The Scheme below is a loose translation of some Python code
;;; by Guido van Rossum, CWI Amsterdam <guido@cwi.nl>
;;;
;;;+f
;;; Look for the string `substr' in the string `str'
;;; If it is there, return the position of the start of it, otherwise
;;; return #false
;;;-f
;;; Note the current method is very poor for long strings.
;;; Should implement a Boyer-Moore or some other fast search.
;;;
(define (string-find-string str substr . optional-start)
  (let* ((start (if optional-start (car optional-start) 0))
	 (len-substr (string-length substr))
	 (len-str (string-length str))
	 (max (- len-str len-substr)))
    (let loop ((left start))
      (cond ((> left max) #f)
	    ((string=? (substring str left (+ left len-substr)) substr) left)
	    (else (loop (+ 1 left)))))))

;;;+f
;;; Look for the character `chr' in the string `str' optionally starting
;;; at position `start-pos'
;;; Returns the first position in the string at which the character is found
;;; of #f if the character wasn't found.
;;;-f
(define (string-find-char str chr . start-pos)
  (let ((len (string-length str)))
    (let find ((pos (if start-pos (car start-pos) 0)))
      (cond ((>= pos len) #f)
	    ((char=? (string-ref str pos) chr) pos)
	    (else (find (+ 1 pos)))))))
	     
;;;+f
;;; Checks if the string `prefix' is a prefix of the string `str'
;;; If it is it returns #t
;;;-f
;;; This is a loose translation of the following C by Karl Heuer.
;;;
;;; char *strpref(char const *s, char const *t) {
;;;    while (*t != '\0') if (*s++ != *t++) return (NULL);
;;;    return ((char *)s);
;;; }
;;;
(define (string-prefix? str prefix)
  (let ((prefix-len (string-length prefix))
	(str-len (string-length str)))
    (let loop ((str-pos 0))
      (cond ((= str-pos prefix-len) #t)
	    ((= str-pos str-len) (<= prefix-len str-len))
	    ((char=? (string-ref str str-pos) (string-ref prefix str-pos))
	     (loop (+ 1 str-pos)))
	    (else #f)))))

;;; The Scheme below is an implementation of the following C function.
;;; Description is by Dan Bernstein <brnstnd@kramden.acf.nyu.edu>
;;;
;;;  int strinfdiff(sf,tf) returns 0 if sf and tf are the same, -1 if sf is
;;;  a prefix of tf, -2 if it is not a prefix but is strictly smaller
;;;  (compared in dictionary order with individual chars unsigned), 1 if tf
;;;  is a prefix of sf, and 2 if tf is smaller than sf but not a prefix.
;;;
(define (string-diff a b)
  (error 'string-diff "not implemented yet"))

;;;+f
;;; Produce a string of size `width' in which the string `s1' is positioned
;;; at the left and `s2' is used to pad out the remaining characters to
;;; the right.  For example :-
;;;   (string-left "Detroit" 10 "+") == "Detroit+++"
;;;   (string-left "Detroit" 6)      == "Detroi"
;;; Based on the Icon function left(s1, i, s2)
;;;-f
(define (string-left s1 width . s2)
  (let ((padding (if s2 (car s2) " "))
	(str-len (string-length s1)))
    (cond ((> width str-len)
	   (string-append s1 (string-replw padding (- width str-len))))
	  ((< width str-len) (substring s1 0 width))
	  (else s1))))

;;;+f
;;; Generate `copies' number of copies of the string `str'
;;; For example :-
;;;   (string-replc "+*+" 3) == "+*++*++*+"
;;;   (string-replc s 0) == ""
;;; Based on the Icon function repl(s, i)
;;; Returns : string
;;;-f
(define (string-replc str copies)
  (let loop ((result "") (count copies))
    (if (zero? count)
	result
	(loop (string-append str result) (- count 1)))))

;;;+f
;;; Geneate a string which is `width' characters long consisting on the
;;; given string `str'.  For example :-
;;;   (string-replw "abc" 10) == "abcabcabca"
;;;   (string-replw "abc" 1)  == "a"
;;;   (string-replw "abc" 0)  == ""
;;;   (string-replw ""    1)  == ""
;;;-f
(define (string-replw str width)
  (if (string=? str "")
      ""
      (let ((str-len (string-length str)))
	(let loop ((result "") (size 0))
	  (cond ((= size width) result)
		((> size width) (substring result 0 width))
		(else (loop (string-append result str) (+ size str-len))))))))

;;;+f
;;; Produces a string consisting of the characters of the string `str'
;;; in reverse order.  For example :-
;;;   (string-reverse "string") == "gnirts"
;;;   (string-reverse "") == ""
;;; Based on the Icon function reverse(s)
;;; Returns : string
;;;-f
(define (string-reverse str)
  (let ((result (make-string (string-length str) #\Space)))
    (let loop ((low 0) (high (string-length str)))
      (if (zero? high)
	  result
	  (begin
	    (let ((new-high (- high 1)))
	      (string-set! result low (string-ref str new-high))
	      (loop (+ 1 low) new-high)))))))

;;;+f
;;; Produce a string of size `width' in which the string `s1' is positioned
;;; at the right and `s2' is used to pad out the remaining characters to
;;; the left.  For example :-
;;;   (string-right "Detroit" 10 "+") == "+++Detroit"
;;;   (string-right "Detroit" 6)      == "etroit"
;;; Based on the Icon function right(s1, i, s2)
;;;-f
(define (string-right s1 width . s2)
  (let ((padding (if s2 (car s2) " "))
	(str-len (string-length s1)))
    (cond ((> width str-len)
	   (string-append (string-replw padding (- width str-len)) s1))
	  ((< width str-len) (substring s1 (- str-len width) str-len))
	  (else s1))))

;;; The Scheme below is a loose translation of the following Python code
;;; by Guido van Rossum, CWI Amsterdam <guido@cwi.nl>
;;;
;;; # Split a string into a list of space/tab-separated words
;;; # NB: split(s) is NOT the same as splitfields(s, ' ')!
;;; def split(s):
;;;	res = []
;;;	i, n = 0, len(s)
;;;	while i < n:
;;;		while i < n and s[i] in whitespace: i = i+1
;;;		if i = n: break
;;;		j = i
;;;		while j < n and s[j] not in whitespace: j = j+1
;;;		res.append(s[i:j])
;;;		i = j
;;;	return res
;;;+f
;;; Returns a list of whitespace delimited words in the string `str'.
;;; If the string is empty or contains only whitespace, then
;;; it returns the empty list.
;;;-f
(define (string-split-whitespace str)
  (define (skip-whitespace str pos)
    (cond ((zero? pos) pos)
	  ((char-whitespace? (string-ref str pos))
	   (skip-whitespace str (- pos 1)))
	  (else pos)))
  (define (skip-non-whitespace str pos)
    (cond ((zero? pos)
	   (if (char-whitespace? (string-ref str pos))
	       (+ 1 pos)
	       pos))
	  ((char-whitespace? (string-ref str pos)) (+ 1 pos))
	  (else (skip-non-whitespace str (- pos 1)))))
      (define (string-split-tr str pos result)
    (let ((end (skip-whitespace str pos)))
      (if (zero? end)
	  result
	  (let* ((start (skip-non-whitespace str end))
		 (new-result (cons (substring str start (+ 1 end)) result)))
	    (if (zero? start)
		new-result
		(string-split-tr str (- start 1) new-result))))))
  (let ((result '())
    	(strlen (string-length str)))
    (if (zero? strlen)
	result
	(string-split-tr str (- strlen 1) result))))

;;; The Scheme below is a loose translation of the following Python code
;;; by Guido van Rossum, CWI Amsterdam <guido@cwi.nl>
;;; 
;;; # Strip leading and trailing tabs and spaces
;;; def strip(s):
;;;	i, j = 0, len(s)
;;;	while i < j and s[i] in whitespace: i = i+1
;;;	while i < j and s[j-1] in whitespace: j = j-1
;;;	return s[i:j]
;;;+f
;;; Strip the leading and trailing whitespace from the string `str'
;;;-f
(define (string-trim-whitespace str)
  (define (string-trim-left str left len)
    (if (and (< left len) (char-whitespace? (string-ref str left)))
	(string-trim-left str (+ 1 left) len)
	left))
  (define (string-trim-right str left right)
    (if (and (< left right) (char-whitespace? (string-ref str (- right 1))))
	(string-trim-right str left (- right 1))
	right))
  (let* ((len (string-length str))
	 (left (string-trim-left str 0 len))
	 (right (string-trim-right str left len)))
    (substring str left right)))


(provide 'string-extensions)
