;;;; -*- 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.27 2003/05/14 21:31:42 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)

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

;; From Larry Hunter with modifications
(defun position-char (char string start max)
  (declare (optimize (speed 3) (safety 0) (space 0))
	   (fixnum start max) (simple-string string))
  (do* ((i start (1+ i)))
       ((= i max) nil)
    (declare (fixnum i))
    (when (char= char (schar string i)) (return i))))

(defun delimited-string-to-list (string &optional (separator #\space) 
						  skip-terminal)
  "split a string with delimiter"
  (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0))
	   (type string string)
	   (type character separator))
  (do* ((len (length string))
	(output '())
	(pos 0)
	(end (position-char separator string pos len)
	     (position-char separator string pos len)))
       ((null end)
	(if (< pos len)
	    (push (subseq string pos) output)
	    (when (or (not skip-terminal) (zerop len))
	      (push "" output)))
	(nreverse output))
    (declare (type fixnum pos len)
	     (type (or null fixnum) end))
    (push (subseq string pos end) output)
    (setq pos (1+ end))))


(defun list-to-delimited-string (list &optional (separator #\space))
  (format nil (format nil "~~{~~A~~^~A~~}" separator) 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"
  (substitute-chars-strings procstr (list (cons match-char subst-str))))

(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"
  (let ((len (length s)))
    (if (plusp len)
	(subseq s 0 (1- len))
	s)))

(defun nstring-trim-last-character (s)
  "Return the string less the last character"
  (let ((len (length s)))
    (if (plusp len)
	(nsubseq s 0 (1- len))
	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))
  (locally (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 replaced-string-length (str repl-alist)
  (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 (1- (length (cdr match)))))))
    new-len))

(defun substitute-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 (simple-string str))
  (do* ((orig-len (length str))
	(new-string (make-string (replaced-string-length str repl-alist)))
	(spos 0 (1+ spos))
	(dpos 0))
      ((>= spos orig-len)
       new-string)
    (declare (fixnum spos dpos) (simple-string new-string))
    (let* ((c (char str spos))
	   (match (assoc c repl-alist :test #'char=)))
      (declare (character c))
      (if match
	  (let* ((subst (cdr match))
		 (len (length subst)))
	    (declare (fixnum len))
	    (dotimes (j len)
	      (declare (fixnum j))
	      (setf (char new-string dpos) (char subst j))
	      (incf dpos)))
	(progn
	  (setf (char new-string dpos) c)
	  (incf dpos))))))

(defun escape-xml-string (string)
  "Escape invalid XML characters"
  (substitute-chars-strings 
   string '((#\& . "&amp;") (#\> . "&gt;") (#\< . "&lt;") (#\" . "&quot;"))))


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

(defun concat-separated-strings (separator &rest lists)
  (format nil (format nil "~~{~~A~~^~A~~}" separator) (append-sublists lists)))

(defun only-null-list-elements-p (lst)
  (or (null lst) (every #'null lst)))

(defun print-separated-strings (strm separator &rest lists)
  (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)
		     (compilation-speed 0)))
  (do* ((rest-lists lists (cdr rest-lists))
	(list (car rest-lists) (car rest-lists))
	(last-list (only-null-list-elements-p (cdr rest-lists))
		   (only-null-list-elements-p (cdr rest-lists))))
       ((null rest-lists) strm)
    (do* ((lst list (cdr lst))
	  (elem (car lst) (car lst))
	  (last-elem (null (cdr lst)) (null (cdr lst))))
	 ((null lst))
      (write-string elem strm)
      (unless (and last-elem last-list)
	(write-string separator strm)))))

(defun prefixed-fixnum-string (num pchar len)
  "Outputs a string of LEN chars with the initial character being
PCHAR. Leading zeros are printed."
  (declare (optimize (speed 3) (safety 0) (space 0))
	   (type fixnum v len))
  (let ((zero-code (char-code #\0))
	(result (make-string len :initial-element #\0))
	(pos (1- len)))
    (declare (fixnum zero-code pos)
	     (simple-string result))
    (do* ((val num (floor (/ val 10)))
	  (mod (nth-value 1 (floor val 10))
	       (nth-value 1 (floor val 10))))
	 ((or (zerop val) (minusp pos)))
      (declare (fixnum val mod))
      (setf (schar result pos) (code-char (+ zero-code mod)))
      (decf pos))
    (when pchar
      (setf (schar result 0) pchar))
    result))