;;;;
;;;; str.stk	-- string operations
;;;;
;;;; Copyright © 2011 Erick Gallesio - Polytech'Nice-Sophia <eg@unice.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date: 14-Jul-2011 16:42 (eg)
;;;; Last file update: 10-Aug-2011 16:17 (eg)
;;;;

;;; The functions defined here replace C primitives which are not UTF-8 aware.
;;; These functions still use their correspondant C primitive if the string
;;; argument doesn't use multi-byte characters


(when (%use-utf8?)
  (let ((%string-split		string-split)
	(%string-blit!		string-blit!)
	(%string-titlecase	string-titlecase)
	(%string-titlecase!	string-titlecase!)
	(error-bad-string	(lambda (str)
				  (error "bad string ~S" str))))
    ;;
    ;; string-split
    ;;
    (set! string-split
      (lambda (str :optional (delimiters  " \t\n"))
	(if (not (%string-use-utf8? str))
	    (%string-split str delimiters)
	    (begin
	      (unless (string? str)
		(error-bad-string str))
	      (unless (string? delimiters)
		(error-bad-string delimiters))

	      (let ((len   (string-length str))
		    (delim (string->list delimiters)))
		(let Loop ((start 0)
			   (current 0)
			   (res '()))
		  (cond
		    (( = current len)
		     (reverse! (if (> current start)
				   (cons (substring str start current) res)
				   res)))
		    ((memq (string-ref str current) delim)
		     (if (> current start)
			 (Loop (+ current 1)
			       (+ current 1)
			       (cons (substring str start current) res))
			 (Loop (+ current 1)
			       (+ current 1)
			       res)))
		    (else
		     (Loop start
			   (+ current 1)
			   res)))))))))
    ;;
    ;; string-blit!
    ;;
    (set! string-blit!
      (lambda (str1 str2 offset)
	(if (not (and (%string-use-utf8? str1) (%string-use-utf8? str2)))
	    (%string-blit! str1 str2 offset)
	    (begin
	      (unless (string? str1)
		(error-bad-string str1))
	      (unless (string? str2)
		(error-bad-string str2))
	      (unless (integer? offset)
		(error "bad offset ~S" offset))
	      (unless (string-mutable? str1)
		(error "changing the constant string ~S is not allowed"))

	      (let ((len1 (string-length str1))
		    (len2 (string-length str2)))
		(cond
		  ((and (zero? len1) (zero? offset))
		   str2)
		  ((< (+ offset len2) len1)
		   ;; str2 can be written in str1
		   (dotimes (i len2)
		     (string-set! str1 (+ offset i) (string-ref str2 i)))
		   str1)
		  (else
		   ;; Size of original string changes => allocate a new string
		   (let* ((newl (if (>= len1 (+ offset len2)) len1 (+ offset len2)))
			  (new  (make-string newl)))
		     (let Loop ((i 0)
				(j 0))
		       (cond
			 ((= i newl)
			  new)
			 ((and (>= i offset) (< i (+ offset len2)))
			  (string-set! new i (string-ref str2 j))
			  (Loop (+ i 1) (+ j 1)))
			 ((< i len1)
			  (string-set! new i (string-ref str1 i))
			  (Loop (+ i 1) j))
			 (else
			  (Loop (+ i 1) j))))))))))))

    ;;
    ;; string-titlecase
    ;;
    (set! string-titlecase
      (lambda (str :optional (start 0) (end -1))
	(if (not (%string-use-utf8? str))
	    (%string-titlecase str start end)
	    (begin
	      (unless (string? str)
		(error-bad-string  str))
	      (unless (integer? start)
		(error "bad starting index ~S" start))
	      (cond
		((not (integer? end))
		 (error "bad ending index ~S" end))
		((= end -1)
		 (set! end (string-length str))))

	      (let ((new (make-string (- end start))))
		(let Loop ((i start)
			   (j 0)
			   (prev-is-sep? #t))
		  (if (= i end)
		      new
		      (let* ((curr (string-ref str i))
			     (curr-is-sep? (not (char-alphabetic? curr))))
			(string-set! new j (cond
					     (curr-is-sep?  curr)
					     (prev-is-sep?  (char-upcase curr))
					     (else          (char-downcase curr))))
			(Loop (+ i 1) (+ j 1) curr-is-sep?)))))))))



    ;;
    ;; string-titlecase!
    ;;
    (set! string-titlecase!
      (lambda (str :optional (start 0) (end -1))
	(if (not (%string-use-utf8? str))
	    (%string-titlecase! str start end)
	    (begin
	      (unless (string? str)
		(error-bad-string str))
	      (unless (integer? start)
		(error "bad starting index ~S" start))
	      (cond
		((not (integer? end))
		 (error "bad ending index ~S" end))
		((= end -1)
		 (set! end (string-length str))))

	      (let Loop ((i start)
			 (prev-is-sep? #t))
		(if (= i end)
		    (void)
		    (let* ((curr (string-ref str i))
			   (curr-is-sep? (not (char-alphabetic? curr))))
		      (string-set! str i (cond
					   (curr-is-sep?  curr)
					   (prev-is-sep?  (char-upcase curr))
					   (else          (char-downcase curr))))
		      (Loop (+ i 1) curr-is-sep?))))))))
    ))