;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name:          strings.lisp
;;;; Purpose:       Strings utility functions for KMRCL package
;;;; Programmer:    Kevin M. Rosenberg
;;;; Date Started:  Apr 2000
;;;;
;;;; $Id: strings.lisp,v 1.8 2003/04/28 16:07:43 kevin Exp $
;;;;
;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
;;;; KMRCL users are granted the rights to distribute and use this software
;;;; as governed by the terms of the Lisp Lesser GNU Public License
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************


(in-package :kmrcl)
(declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))

;;; Strings

(defmacro string-append (outputstr &rest args)
  `(setq ,outputstr (concatenate 'string ,outputstr ,@args)))

(defun list-to-string (lst)
  "Converts a list to a string, doesn't include any delimiters between elements"
  (format nil "~{~A~}" lst))

(defun count-string-words (str)
  (declare (simple-string str)
	   (optimize (speed 3) (safety 0)))
  (let ((n-words 0)
	(in-word nil))
    (declare (fixnum n-words))
    (dotimes (i (length str))
      (let ((ch (char str i)))
	(declare (character ch))
	(if (alphanumericp ch)
	    (unless in-word
	      (incf n-words)
	      (setq in-word t))
	  (setq in-word nil))))
    n-words))

#+excl
(defun delimited-string-to-list (string &optional (separator #\space))
  (excl:delimited-string-to-list string separator))

#-excl
(defun delimited-string-to-list (sequence &optional (separator #\space))
  "Split a string by a delimitor"
  (loop
      with start = 0
      for end = (position separator sequence :start start)
      collect (subseq sequence start end)
      until (null end)
      do
    (setf start (1+ end))))

#+excl
(defun list-to-delimited-string (list &optional (separator #\space))
  (excl:list-to-delimited-string list separator))

#-excl
(defun list-to-delimited-string (list &optional (separator #\space))
  (if (consp list)
      (let ((fmt (format nil "~~A~~{~A~~A~~}" separator)))
	(format nil fmt (first list) (rest list)))
      ""))

(defun string-invert (str)
  "Invert case of a string"
  (declare (optimize (speed 3) (compilation-speed 0) (debug 0) (safety 0))
           (simple-string str))
  (let ((up nil) (down nil))
    (block skip
      (loop for char of-type character across str do
	    (cond ((upper-case-p char) (if down (return-from skip str) (setf up t)))
		  ((lower-case-p char) (if up   (return-from skip str) (setf down t)))))
      (if up (string-downcase str) (string-upcase str)))))

(defun add-sql-quotes (s)
  (substitute-string-for-char s #\' "''"))

(defun escape-backslashes (s)
  (substitute-string-for-char s #\\ "\\\\"))

(defun substitute-string-for-char (procstr match-char subst-str) 
  "Substitutes a string for a single matching character of a string"
  (let ((pos (position match-char procstr)))
    (if pos
	(concatenate 'string
	  (subseq procstr 0 pos) subst-str
	  (substitute-string-for-char (subseq procstr (1+ pos)) match-char subst-str))
      procstr)))

(defun string-substitute (string substring replacement-string)
  "String substitute by Larry Hunter. Obtained from Google"
  (let ((substring-length (length substring))
	(last-end 0)
	(new-string ""))
    (do ((next-start
	  (search substring string)
	  (search substring string :start2 last-end)))
	((null next-start)
	 (concatenate 'string new-string (subseq string last-end)))
      (setq new-string
	(concatenate 'string
	  new-string
	  (subseq string last-end next-start)
	  replacement-string))
      (setq last-end (+ next-start substring-length)))))


(defun string-trim-last-character (s)
"Return the string less the last character"
  (subseq s 0 (1- (length s))))

(defun string-hash (str &optional (bitmask 65535))
  (let ((hash 0))
    (declare (fixnum hash)
	     (simple-string str))
    (dotimes (i (length str))
      (declare (fixnum i))
      (setq hash (+ hash (char-code (char str i)))))
    (logand hash bitmask)))

(defun string-not-null? (str)
  (and str (not (zerop (length str)))))
  
(defun whitespace? (c) 
  (declare (character c))
  (declare (optimize (speed 3) (safety 0)))
  (or (char= c #\Space) (char= c #\Tab) (char= c #\Return) (char= c #\Linefeed)))

(defun not-whitespace? (c)
  (not (whitespace? c)))

(defun string-ws? (str)
  "Return t if string is all whitespace"
  (when (stringp str)
    (null (find-if #'not-whitespace? str))))

(defun string-replace-chars-strings (str repl-alist)
  "Replace all instances of a chars with a string. repl-alist is an assoc
list of characters and replacement strings."
  (declare (string str))
  (let* ((orig-len (length str))
	 (new-len orig-len))
    (declare (fixnum orig-len new-len))
    (dotimes (i orig-len)
      (declare (fixnum i))
      (let* ((c (char str i))
	     (match (assoc c repl-alist :test #'char=)))
	(declare (character c))
	(when match
	  (incf new-len (length (cdr match))))))
    (let ((new-string (make-string new-len))
	  (i 0))
      (declare (string new-string)
	       (fixnum i))
      (dotimes (i orig-len)
	(declare (fixnum i))
	(let* ((c (char str i))
	       (match (assoc c repl-alist :test #'char=)))
	  (declare (character c))
	  (if match
	      (let ((subst (cdr match)))
		(dotimes (j (length subst))
		  (setf (char new-string i) (char subst j))
		  (incf i)))
	    (progn
	      (setf (char new-string i) c)))))
      new-string)))

(defun escape-xml-string (string)
  "Escape invalid XML characters"
  (string-replace-char-string
   (string-replace-char-string string #\& "&")
   #\< "&lt;"))

(defun string-replace-char-string (string repl-char repl-str)
  "Replace all occurances of repl-char with repl-str"
 (declare (simple-string string))
  (let ((count (count repl-char string)))
    (declare (fixnum count))
    (if (zerop count)
	string
	(locally (declare (optimize (speed 3) (safety 0)))
	  (let* ((old-length (length string))
		 (repl-length (length repl-str))
		 (new-string (make-string (the fixnum
					    (+ old-length
					       (the fixnum
						 (* count
						    (the fixnum (1- repl-length)))))))))
	    (declare (fixnum old-length repl-length)
		     (simple-string new-string))
	    (let ((newpos 0))
	      (declare (fixnum newpos))
	      (dotimes (oldpos (length string))
		(declare (fixnum oldpos))
		(if (char= repl-char (schar string oldpos))
		    (dotimes (repl-pos repl-length)
		      (declare (fixnum repl-pos))
		      (setf (schar new-string newpos) (schar repl-str repl-pos))
		      (incf newpos))
		    (progn
		      (setf (schar new-string newpos) (schar string oldpos))
		      (incf newpos)))))
	    new-string)))))

    

(defun make-usb8-array (len)
  (make-array len :adjustable nil
	      :fill-pointer nil
	      :element-type '(unsigned-byte 8)))

(defun usb8-array-to-string (vec)
  (let* ((len (length vec))
	 (str (make-string len)))
    (declare (fixnum len)
	     (simple-string str)
	     (optimize (speed 3)))
    (dotimes (i len)
      (declare (fixnum i))
      (setf (schar str i) (code-char (aref vec i))))
    str))

(defun string-to-usb8-array (str)
  (let* ((len (length str))
	 (vec (make-usb8-array len)))
    (declare (fixnum len)
	     (type (array fixnum (*)) vec)
	     (optimize (speed 3)))
    (dotimes (i len)
      (declare (fixnum i))
      (setf (aref vec i) (char-code (schar str i))))
    vec))