;;;;
;;;; str.stk    -- string operations
;;;;
;;;; Copyright © 2011-2022 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)
;;;;

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

