;;; -*- Mode:LISP; Package:LISP-INTERNALS; Readtable:CL; Base:10 -*-

;;;a list of functions defined below
;MAKE-STRING
;CHAR
;SCHAR
;STRING=
;STRING/=
;STRING<
;STRING<=
;STRING>
;STRING>=
;STRING-EQUAL
;STRING-LESSP
;STRING-NOT-EQUAL
;STRING-NOT-LESSP
;STRING-NOT-GREATERP
;STRING-GREATERP
;STRING-UPCASE
;STRING-DOWNCASE
;NSTRING-UPCASE 
;NSTRING-DOWNCASE
;STRING-TRIM
;STRING-TRIM-LEFT
;STRING-TRIM-RIGHT

;;; things not defined that are in steele's book
;STRING-CAPITALIZE
;NSTRING-CAPITALIZE

;;; This is the real MAKE-STRING.  There is also a rewriter for the compiler
;;; to optimize the simple case of there not being an initial element specified.
(defun MAKE-STRING (length &key (initial-element nil init-p))
  (let ((string (array::make-string-no-init length)))
    (when init-p
      (dotimes (i length)
	(setf (svref string i) initial-element)))
    string))

;;; a rewriter for MAKE-STRING uses this
(defun make-string-with-init (length initial-element)
  (let ((string (array::make-string-no-init length)))
    (dotimes (i length)
      (setf (svref string i) initial-element))
    string))

(defun CHAR (string index)
  (if (stringp string)
      (svref string index)
    (li:error "Not a string")))

(defun SCHAR (string index)
  (if (simple-string-p string)
      (svref string index)
    (li:error "Not a simple string")))

(defun string (x)
  (cond
    ((stringp x) x)
    ((symbolp x) (symbol:symbol-name x))
    ((and (vinc:characterp x)
	  (string-char-p x))
     (li::make-string-with-init 1 x))
    (t (li:error "~x cannot be coerced to a string." x))))
			           
; test-bits are the type of test:   (GT EQ LT)
;   001 - less than
;   010 - equal
;   011 - less or equal
;   100 - greater
;   101 - not equal
;   110 - greater or equal

(defun STRING= (string1 string2 &key (start1 0) (end1 nil) (start2 0) (end2 nil))
  (string-compare string1 string2 start1 end1 start2 end2 #b010 t))

(defun STRING/= (string1 string2 &key (start1 0) (end1 nil) (start2 0) (end2 nil))
  (string-compare string1 string2 start1 end1 start2 end2 #b101 t))

(defun STRING< (string1 string2 &key (start1 0) (end1 nil) (start2 0) (end2 nil))
  (string-compare string1 string2 start1 end1 start2 end2 #b001 t))

(defun STRING<= (string1 string2 &key (start1 0) (end1 nil) (start2 0) (end2 nil))
  (string-compare string1 string2 start1 end1 start2 end2 #b011 t))

(defun STRING> (string1 string2 &key (start1 0) (end1 nil) (start2 0) (end2 nil))
  (string-compare string1 string2 start1 end1 start2 end2 #b100 t))

(defun STRING>= (string1 string2 &key (start1 0) (end1 nil) (start2 0) (end2 nil))
  (string-compare string1 string2 start1 end1 start2 end2 #b110 t))

(defun STRING-EQUAL (string1 string2 &key (start1 0) (end1 nil) (start2 0) (end2 nil))
  (string-compare string1 string2 start1 end1 start2 end2 #b010 nil))

(defun STRING-NOT-EQUAL (string1 string2 &key (start1 0) (end1 nil) (start2 0) (end2 nil))
  (string-compare string1 string2 start1 end1 start2 end2 #b101 nil))

(defun STRING-LESSP (string1 string2 &key (start1 0) (end1 nil) (start2 0) (end2 nil))
  (string-compare string1 string2 start1 end1 start2 end2 #b001 nil))

(defun STRING-NOT-LESSP (string1 string2 &key (start1 0) (end1 nil) (start2 0) (end2 nil))
  (string-compare string1 string2 start1 end1 start2 end2 #b110 nil))

(defun STRING-GREATERP (string1 string2 &key (start1 0) (end1 nil) (start2 0) (end2 nil))
  (string-compare string1 string2 start1 end1 start2 end2 #b100 nil))

(defun STRING-NOT-GREATERP (string1 string2 &key (start1 0) (end1 nil) (start2 0) (end2 nil))
  (string-compare string1 string2 start1 end1 start2 end2 #b011 nil))

(defun string-compare (string1 string2 start1 end1 start2 end2 test fussy?)
  (setq string1 (string string1))
  (setq string2 (string string2))
  (let ((length1 (length string1))
	(length2 (length string2)))
    (if (null end1)
	(setq end1 length1)
      (when (> end1 length1) (li:error "STRING-COMPARE: end greater than length for STRING1")))
    (if (null end2)
	(setq end2 length2)
      (when (> end2 length2) (li:error "STRING-COMPARE: end greater than length for STRING2")))
    (unless (and (<= 0 start1) (<= start1 end1)
		 (<= 0 start2) (<= start2 end2))
      (li:error "STRING-COMPARE: START and END arguments in wrong order"))
    (setq length1 (- end1 start1))
    (setq length2 (- end2 start2))
    (let* ((min (if (< length1 length2) length1 length2))
	   (fast (array::%fast-string= string1 start1 string2 start2 min)))
      (do ((i fast (1+ i)))
	  ((>= i min))
	(let ((char1 (svref string1 (+ start1 i)))
	      (char2 (svref string2 (+ start2 i))))
	  (when (if fussy?
		    (%char/= char1 char2)
		  (char-not-equal char1 char2))
	    (return-from string-compare
	      (and (not (zerop
			  (logand test (if (if fussy?
					       (%char< char1 char2)
					     (char-lessp char1 char2))
					   #b001 #b100))))
		   i)))))
      (and (not (zerop (logand test
			       (cond
				 ((= length1 length2) #b010)
				 ((< length1 length2) #b001)
				 (t                   #b100)))))
	   min))))

(defun STRING-UPCASE (string &key (start 0) (end nil))
  (let* ((str (string string))
	 (length (length string))
	 (new-string (array::make-string-no-init length)))
    (unless end (setq end length))
    (dotimes (i length)
      (setf (svref new-string i)
	    (if (and (>= i start) (< i end))
		(char-upcase (svref str i))
	      (svref str i))))
    new-string))

(defun STRING-DOWNCASE (string &key (start 0) (end nil))
  (let* ((str (string string))
	 (length (length string))
	 (new-string (array::make-string-no-init length)))
    (unless end (setq end length))
    (dotimes (i length)
      (setf (svref new-string i)
	    (if (and (>= i start) (< i end))
		(char-downcase (svref str i))
	      (svref str i))))
    new-string))

(defun NSTRING-UPCASE (string &key (start 0) (end nil))
  (check-type string string)
  (let* ((length (length string)))
    (unless end (setq end length))
    (do ((i start (1+ i)))
	((>= i end)
	 string)
      (unless (upper-case-p (svref string i))
	(setf (svref string i)
	      (char-upcase (svref string i)))))))

(defun NSTRING-DOWNCASE (string &key (start 0) (end nil))
  (check-type string string)
  (let* ((length (length string)))
    (unless end (setq end length))
    (do ((i start (1+ i)))
	((>= i end)
	 string)
      (unless (lower-case-p (svref string i))
	(setf (svref string i)
	      (char-downcase (svref string i)))))))

;;; In this implementation STRING-CAPITALIZE and NSTRING-CAPITALIZE assume:
;;;  *  (string-capitalize "555FF") ==> "555ff"		that is '555FF' is a word and all but the
;;;							first character are make lower-case.
;;;  *  (string-capitalize "abcdefg" :start 2) ==> "abCdefg"
;;; 		that is that characters in the string before START are not considered
;;;		when determining where a word begins.

(defun STRING-CAPITALIZE (string &key (start 0) (end nil))
  (let* ((string (string string))
	 (length (length string))
	 (new-string (make-string length))
	 (index 0))
    (unless end (setq end length))
    (macrolet ((this-char ()
		 `(svref string index))
	       (copy ()
		 `(setf (svref new-string index) (svref string index)))
	       (advance ()
		 `(progn (setq index (1+ index))
			 (when (>= index end) (go at-end))))
	       (upcase ()
		 `(setf (svref new-string index) (char-upcase (svref string index))))
	       (downcase ()
		 `(setf (svref new-string index) (char-downcase (svref string index)))))
      (tagbody
       before-start
	  (when (< index start)
	    (copy) (advance) (go before-start))
       find-word
	  (unless (alphanumericp (this-char))
	    (copy) (advance) (go find-word))
	  ;;; we are now at the beginning of a word
	  (upcase) (advance)
       in-word
	  (when (alphanumericp (this-char))
	    (downcase) (advance) (go in-word))
	  (go find-word)
       at-end
	  (when (< index length)
	    (copy) (advance) (go at-end))
       new-string))))


(defun NSTRING-CAPITALIZE (string &key (start 0) (end nil))
  (unless (stringp string)
    (error "Not a string to NSTRING-CAPITALIZE" string))
  (let* ((length (length string))
	 (index start))
    (unless end (setq end length))
    (macrolet ((this-char ()
		 `(svref string index))
	       (advance ()
		 `(progn (setq index (1+ index))
			 (when (>= index end) (go at-end))))
	       (upcase ()
		 `(setf (svref string index) (char-upcase (svref string index))))
	       (downcase ()
		 `(setf (svref string index) (char-downcase (svref string index)))))
      (tagbody
       find-word
	  (unless (alphanumericp (this-char))
	    (advance) (go find-word))
	  ;;; we are now at the beginning of a word
	  (upcase) (advance)
       in-word
	  (when (alphanumericp (this-char))
	    (downcase) (advance) (go in-word))
	  (go find-word)
       at-end
       string))))


(defun STRING-TRIM (character-bag string)
  (let* ((string (string string))
	 (length (length string)))
    (subseq string
	    (string-trim-scan-left-to-right character-bag string length)
	    (string-trim-scan-right-to-left character-bag string length))))

(defun STRING-TRIM-LEFT (character-bag string)
  (let* ((string (string string))
	 (length (length string)))
    (subseq string (string-trim-scan-left-to-right character-bag string length))))

(defun STRING-TRIM-RIGHT (character-bag string)
  (let* ((string (string string))
	 (length (length string)))
    (subseq string 0 (string-trim-scan-right-to-left character-bag string length))))

(defun string-trim-scan-left-to-right (character-bag string end)
  (do ((index 0 (1+ index)))
      ((>= index end) end)
    (unless (position (svref string index) character-bag)
      (return index))))

(defun string-trim-scan-right-to-left (character-bag string end)
  (do ((index end (1- index)))
      ((<= index 0) 0)
    (unless (position (svref string index) character-bag)
      (return index))))