;;;-*- Mode: Lisp; Package: UTILS -*-

(in-package :utils)

#+ignore
(export '(subst-substrings last-char first-char string-member string-member-equal find-equal search-all
          parse-string string-parse ncat ncat-with-prefix concat concat-substrings concat-with-infix
          concat-with-infix-suffix subst-chars-by-substrings remove-substrings count-substring
          string-to-keyword string-starts-with-p string-ends-with-p trim-ends trim-last split))

(defun split (string char &optional count escape-char ignore-null-chunks-p keep-split-char)
  "COUNT is max number of returned chunks.
When ESCAPE-CHAR precedes CHAR, the string is not splitted at that position."
  (when string
    (labels ((walk (pos)
	       (let ((next-pos (position char string :start pos)))
		 (if (and next-pos
			  (or (null count)
			      (not (zerop (decf count))))
			  (or (null escape-char)
			      (zerop next-pos)
			      (char/= (char string (1- next-pos)) escape-char)))
                   (if (and ignore-null-chunks-p (= pos next-pos))
                     (walk (1+ next-pos))
                     (cons (subseq string (if (and keep-split-char
						   (not (eq keep-split-char :right))
						   (not (zerop pos)))
                                            (1- pos)
                                            pos)
				   (if (eq keep-split-char :right)
				       (1+ next-pos)
				       next-pos))
                           (walk (1+ next-pos))))
                   (unless (and ignore-null-chunks-p (= pos (length string)))
                     (list (subseq string (if (and keep-split-char
						   (not (eq keep-split-char :right))
						   (not (zerop pos)))
                                            (1- pos)
                                            pos))))))))
      (walk 0))))

(defun subst-substrings (string substitutions &key (test #'char=) 
                                        recursive (start 0))
  (loop for ent on substitutions by #'cddr 
        do
        (loop with st = start
              while (setf st (search (string (car ent)) string 
				     :test test :start2 st))
              do (setf string 
                       (concatenate 'string (subseq string 0 st)
                                    (string (cadr ent))
                                    (subseq string (+ st (length (string (car ent)))))))
              (unless recursive (incf st (length (string (cadr ent)))))))
  string)

#+old
(defun convert-string (str from-platform to-platform)
  "from-platform is :mac, :dos or :win; to-platform may be :sgml in addition.
If to-platform is not :sgml, the operation is destructive."
  (case to-platform
    (:sgml
     (unless (eq from-platform :mac)
       (setf str (convert-string str from-platform :mac)))
     (let ((length (length str)))
       (labels 
         ((convert (pos result)
            (if (= pos length)
              result 
              (let ((start pos)
                    entity)
                (loop with char
                      do
                      (setf char (char str pos)
                            entity 
                            (and
                             (not (<= (the fixnum #.(char-code #\A)) 
                                      (the fixnum (char-code char))
                                      (the fixnum #.(char-code #\z))))
                             (gethash char *sgml-char-entity-table*)))
                      (incf pos)
                      until (or (= pos length) entity))
                (cond ((not entity)
                       (concat result (subseq str start)))
                      ((> pos start)
                       (convert pos (concat result (subseq str start pos) entity)))
                      (t
                       (convert pos (concat result entity))))))))
         (convert 0 ""))))
    (t
     (let* ((from-string (getf $platform-string-plist from-platform))
            (to-string (getf $platform-string-plist to-platform)))
       (dotimes (i (length str))
         (let* ((c (char str i))
                (pos (position c from-string)))
           (when pos
             (setf (char str i) (char to-string pos)))))
       str))))

(defun convert-string (str from-platform to-platform &optional additional-conversions)
  "from-platform is :mac/:macintosh, :dos or :win/:windows; to-platform may be :sgml in addition.
If to-platform is not :sgml, the operation is destructive."
  (case to-platform
    (:sgml
     #+ignore
     (unless (member from-platform '(:mac :macintosh))
       (setf str (convert-string str from-platform :mac)))
     (let ((length (length str)))
       (labels 
         ((convert (pos result)
            (if (= pos length)
              result 
              (let ((start pos)
                    (entity nil))
                (loop for char = (char str pos)
                      do (setf entity
                               (or (getf additional-conversions char)
                                   (and (not (<= (the fixnum #.(char-code #\A)) 
                                                 (the fixnum (char-code char))
                                                 (the fixnum #.(char-code #\z))))
                                        (gethash char *sgml-char-entity-table*))))
                      (incf pos)
                      until (or (= pos length) entity))
                (cond ((not entity)
                       (concat result (subseq str start)))
                      ((> pos start)
                       (convert pos (concat result (subseq str start (1- pos)) entity)))
                      (t
                       (convert pos (concat result entity))))))))
         (convert 0 ""))))
    (t
     (let* ((from-string (getf $platform-string-plist from-platform))
            (to-string (getf $platform-string-plist to-platform)))
       (dotimes (i (length str))
         (let* ((c (char str i))
                (pos (position c from-string)))
           (when pos
             (setf (char str i) (char to-string pos)))))
       str))))

#+old?
(defun chars-to-entities (str &optional additional-conversions)
  (let ((length (length str)))
    (labels 
	((convert (pos result)
	   (if (= pos length)
	       result 
	     (let ((start pos)
		   (entity nil))
	       (loop for char = (char str pos)
		   do (setf entity
			(or (getf additional-conversions char)
			    (and (not (<= (the fixnum #.(char-code #\A)) 
					  (the fixnum (char-code char))
					  (the fixnum #.(char-code #\z))))
				 (gethash char *sgml-char-entity-table*))))
                      (incf pos)
		   until (or (= pos length) entity))
	       (cond ((not entity)
		      (concat result (subseq str start)))
		     ((> pos start)
		      (convert pos (concat result (subseq str start (1- pos)) entity)))
		     (t
		      (convert pos (concat result entity))))))))
      (convert 0 ""))))

(defun chars-to-entities (str-or-symbol &optional additional-conversions)
  (let ((str (convert-string
              (typecase str-or-symbol
		(string
		 str-or-symbol)
		(integer ;; temporary fix until lexin-search works
		 (format nil "~a" str-or-symbol))
		(t
		 (string-downcase (string str-or-symbol))))
	      :mac :sgml
	      additional-conversions)))
    str))

(defmethod chars-to-xml-internal-entities ((string string))
  (subst-chars-by-substrings string '(#\& "&amp;"
				      #\< "&lt;"
				      #\> "&gt;"
				      #\' "&apos;"
				      #\" "&quot;")))

(defun last-char (string &optional (from-end 1))
  (unless (string= string "") (char string (- (length string) from-end))))

(defun first-char (string)
  (unless (string= string "") (char string 0)))

(defun search-all (list-of-seq seq &key from-end (test 'eq) (start2 0) 
                                 (end2 (length seq)))
  (loop for seq1 in list-of-seq 
        thereis (search seq1 seq :from-end from-end :test test 
                        :start2 start2 :end2 end2)))

(defun string-parse (str &key brace-pairs ; '((#\( . #\)))
                           delimiter-pairs ; '(("--" . "--"))
                           whitespace ; #(#\Space #\Tab #\Newline))
                           separating-chars
                           left-separating-chars ; #(#\| #\,))
                           right-separating-chars ; #(#\| #\,))
                           (escape-char #\\)
                           (start 0))
  "Splits up a string of words separated by whitespace into a list of those words.
A substring enclosed by brace-pairs is regarded as one word, the same for comments.
It is assumed that braces are balanced."
  (when (zerop (length str))
    (return-from string-parse ()))
  (let ((list ()))
    (loop with brace-depth = 0 and delimiter-flag = nil and escape-flag = nil
          and left = start and i = 0 and str-length = (length str)
          do
          (let ((c (char str i)))
            (cond (escape-flag
                   (setf escape-flag nil)
                   (incf i))
                  ((char= c escape-char)
                   (setf escape-flag t)
                   (incf i))
                  ((and (zerop brace-depth)
                        (not delimiter-flag) 
                        (find c whitespace))
                   (unless (= left i)
                     (push (subseq str left i) list))
                   (setf left (or 
                               (position-if-not #'(lambda (c) (find c whitespace)) 
                                                str :start i)
                               (length str))
                           i left))
                  ((and (zerop brace-depth)
                        (not delimiter-flag) 
                        (find c separating-chars))
                   (push (subseq str left i) list) ; jump over separator 
                   (setf left (incf i))) 
                  ((and (zerop brace-depth)
                        (not delimiter-flag) 
                        (find c left-separating-chars)
                        (< left i))
                   (push (subseq str left i) list)
                   (setf left i)) 
                  ((and (zerop brace-depth)
                        (not delimiter-flag) 
                        (< left i)
                        (find (char str (1- i))
                              (or separating-chars right-separating-chars)))
                   (push (subseq str left i) list)
                   (setf left i))
                  ((and (not delimiter-flag)
                        (loop for pair in delimiter-pairs
                              thereis
                              ;(and (stringp (car pair))
                              (let* ((br (string (car pair)))
                                     (le (length br)))
                                (and
                                 (<= (+ i le) str-length)
                                 (string= br (subseq str i (+ i le)))
                                 (incf i le)
                                 (setf delimiter-flag (cdr pair))))))
                   t ;(setf delimiter-flag t)
                   )
                  ((and delimiter-flag
                        ;(stringp (string (cdr pair)))
                        (let* ((br (string delimiter-flag))
                               (le (length br)))
                          (and
                           (<= (+ i le) str-length)
                           (string= br (subseq str i (+ i le)))
                           (incf i le))))
                   (setf delimiter-flag nil))
                  ((and (not delimiter-flag)
                        (loop for pair in brace-pairs
                              thereis
                              (and (stringp (car pair))
                                   (let* ((br (car pair))
                                          (le (length br)))
                                     (and
                                      (<= (+ i le) str-length)
                                      (string= br
                                               (subseq str i (+ i le)))
                                      (incf i le))))))
                   (incf brace-depth))
                  ((and (not delimiter-flag)
                        (loop for pair in brace-pairs
                              thereis 
                              (and (stringp (cdr pair))
                                   (let* ((br (cdr pair))
                                          (le (length br)))
                                     (and
                                      (<= (+ i le) str-length)
                                      (string= br
                                               (subseq str i (+ i le)))
                                      (incf i le))))))
                   (decf brace-depth))
                  ((find c brace-pairs :key #'car) 
                   (incf brace-depth)
                   (incf i))
                  ((find c brace-pairs :key #'cdr)
                   (decf brace-depth)
                   (incf i)) 
                  (t
                   (incf i)))) 
          until (= i (length str))
          finally (unless (= left i) 
                    (setf list (push (subseq str left i) list) left i)))
    (nreverse list)))

(defun concat-substrings (str &rest start-end-pairs)
  "Concatenates the substrings of str given by the rest list of start and end 
values. The substrings may overlap." 
  (labels ((concat-once (result pairs)
             (if pairs
               (concat-once (ncat result
                                  (subseq str (car pairs) (cadr pairs)))
                            (cddr pairs))
               result)))
    (concat-once "" start-end-pairs)))

(defun concat-with-infix (infix &rest strings)
  "concatenates the strings inserting an infix between each two consecutive strings." 
  (labels ((concat-once (result str-list)
             (if str-list
               (concat-once (ncat result infix (car str-list))
                            (cdr str-list))
               result)))
     (if strings
       (concat-once (car strings) (cdr strings))
       "")))

(defun concat-with-infix-suffix (infix suffix &rest strings)
  "concatenates the strings inserting an infix between each two consecutive strings." 
  (labels ((concat-once (result str-list)
             (if str-list
               (concat-once (ncat result infix (car str-list))
                            (cdr str-list))
               (concat result suffix))))
     (if strings
       (concat-once (car strings) (cdr strings))
       suffix)))

#+old
(defun subst-chars-by-substrings (string substitutions)
  (loop for ent on substitutions by #'cddr 
        do
        (loop with start = 0
              while (setf start (position (car ent) string :start start))
              do (setf string 
                       (concatenate 'string (subseq string 0 start)
                                    (string (cadr ent))
                                    (subseq string (+ start 1))))
              (incf start (length (cadr ent)))))
  string)

(defun subst-chars-by-substrings (string substitutions)
  (loop for (c ent) on substitutions by #'cddr 
        do
        (loop with start = 0
              while (setf start (position c string :start start))
              do (setf string 
                       (concatenate 'string (subseq string 0 start)
                                    (string ent)
                                    (subseq string (+ start 1))))
              (incf start (length ent))))
  string)

(defun remove-substrings (string substrings)
  (loop for ent in substrings
        with start
        do
        (loop while (setf start (search ent string))
              do (setf string 
                       (concatenate 'string (subseq string 0 start)
                                    (subseq string (+ start (length ent)))))))
  string)

(defun count-substring (substr str)
  "removes all occurences of all strings in the list substrings from str"
  (let ((count 0))
    (loop with pos = 0
          do
          (setf pos (search substr str :start2 pos))
          while pos
          do
          (incf count)
          (incf pos))
    count))

#+old
(defun string-to-keyword (obj)
  (if (keywordp obj)
      obj
    (read-from-string (concat ":" obj))))

(defun string-to-keyword (str)
  (intern (string-upcase str) :keyword))

:eof