(define (string-cursor-diff str start end)
  (if (string-cursor? start)
      (- (string-cursor->index str end) (string-cursor->index str start))
      (- end start)))

(define (string-unfold/aux k stop? mapper successor seed . o)
  (let ((base (if (pair? o) (car o) ""))
        (make-final (if (and (pair? o) (pair? (cdr o))) (cadr o) (lambda (x) ""))))
    (do ((acc seed (successor acc))
         (ls '() (cons (mapper acc) ls)))
        ((stop? acc) (k base ls (make-final acc))))))

(define (string-unfold . o)
  (apply string-unfold/aux
         (lambda (base ls final)
           (string-append base (reverse-list->string ls) final))
         o))

(define (string-unfold-right . o)
  (apply string-unfold/aux
         (lambda (base ls final)
           (string-append final (list->string ls) base))
         o))

(define (string-tabulate proc len)
  (string-unfold (lambda (i) (= i len)) proc (lambda (i) (+ i 1)) 0))

(define (string->list/cursors str . o)
  (let ((start (if (pair? o) (car o) (string-cursor-start str)))
        (end (if (and (pair? o) (pair? (cdr o)))
                 (cadr o)
                 (string-cursor-end str))))
    (let lp ((i end) (res '()))
      (if (string-cursor<=? i start)
          res
          (let ((i (string-cursor-prev str i)))
            (lp i (cons (string-cursor-ref str i) res)))))))

(define (string->vector/cursors str . o)
  (list->vector (apply string->list/cursors str o)))

(define (reverse-list->string ls)
  (list->string (reverse ls)))

(define (string-join str-ls . o)
  (let ((sep (if (pair? o) (car o) " "))
        (grammar (if (and (pair? o) (pair? (cdr o))) (cadr o) 'infix)))
    (case grammar
      ((infix)
       (%string-join str-ls sep))
      ((strict-infix)
       (if (null? str-ls)
           (error "string-join 'strict-infix called on an empty list")
           (%string-join str-ls sep)))
      ((prefix)
       (if (null? str-ls) "" (%string-join (cons "" str-ls) sep)))
      ((suffix)
       (if (null? str-ls) "" (string-append (%string-join str-ls sep) sep)))
      (else (error "unknown string-join grammar" grammar)))))

(define (string-ref/cursor str x)
  (if (string-cursor? x)
      (string-cursor-ref str x)
      (string-ref str x)))

(define (substring/cursors str start end)
  (if (string-cursor? start)
      (substring-cursor str start end)
      (substring str start end)))

(define (string-copy/cursors str . o)
  (cond ((null? o) (substring-cursor str (string-cursor-start str)))
        ((string-cursor? (car o)) (apply substring-cursor str o))
        (else (apply substring-cursor str o))))

(define (string-arg str o)
  (if (pair? o) (apply string-copy/cursors str o) str))

(define (cursor-arg str x)
  (if (string-cursor? x) x (string-index->cursor str x)))

(define (cursor-args str o)
  (if (pair? o)
      (cons (cursor-arg str (car o)) (cursor-args str (cdr o)))
      '()))

(define (string-take str n)
  (substring str 0 n))
(define (string-take-right str n)
  (let ((start (string-cursor-back str (string-cursor-end str) n)))
    (substring-cursor str start)))
(define (string-drop str n)
  (substring-cursor str n))
(define (string-drop-right str n)
  (let ((end (string-cursor-back str (string-cursor-end str) n)))
    (substring-cursor str (string-cursor-start str) end)))

(define (string-pad str len . o)
  (let* ((pad-char (if (pair? o) (car o) #\space))
         (str (if (and (pair? o) (pair? (cdr o))) (string-arg str (cdr o)) str))
         (str-len (string-length str)))
    (cond
     ((> str-len len) (string-take-right str len))
     ((< str-len len)
      (string-append (make-string (- len str-len) pad-char) str))
     (else str))))

(define (string-pad-right str len . o)
  (let* ((pad-char (if (pair? o) (car o) #\space))
         (str (if (and (pair? o) (pair? (cdr o))) (string-arg str (cdr o)) str))
         (str-len (string-length str)))
    (cond
     ((> str-len len) (string-take str len))
     ((< str-len len)
      (string-append str (make-string (- len str-len) pad-char)))
     (else str)))) 

(define (string-trim str . o)
  (let ((pred (if (pair? o) (car o) char-whitespace?))
        (str (if (and (pair? o) (pair? (cdr o))) (string-arg str (cdr o)) str)))
    (substring-cursor str (string-skip str pred))))
(define (string-trim-right str . o)
  (let ((pred (if (pair? o) (car o) char-whitespace?))
        (str (if (and (pair? o) (pair? (cdr o))) (string-arg str (cdr o)) str)))
    (substring-cursor str (string-cursor-start str) (string-skip-right str pred))))
(define (string-trim-both str . o)
  (let ((pred (if (pair? o) (car o) char-whitespace?))
        (str (if (and (pair? o) (pair? (cdr o))) (string-arg str (cdr o)) str)))
    (string-trim-right (string-trim str pred) pred)))

(define (string-prefix-length s1 s2 . o)
  (let ((s1 (string-arg s1 o))
        (s2 (if (and (pair? o) (pair? (cdr o))) (string-arg s2 (cddr o)) s2)))
    (string-cursor->index s1 (string-mismatch s1 s2))))
(define (string-suffix-length s1 s2 . o)
  (let* ((s1 (string-arg s1 o))
         (s2 (if (and (pair? o) (pair? (cdr o))) (string-arg s2 (cddr o)) s2))
         (mismatch (string-mismatch-right s2 s1)))
    (string-cursor-diff s1
                        (string-cursor-next s1 mismatch)
                        (string-cursor-end s1))))

(define string-prefix?
  (case-lambda
   ((s1 s2)
    (= (string-length s1) (string-prefix-length s1 s2)))
   ((s1 s2 start1)
    (string-prefix? s1 s2 start1 (string-length s1) 0 (string-length s2)))
   ((s1 s2 start1 end1)
    (string-prefix? s1 s2 start1 end1 0 (string-length s2)))
   ((s1 s2 start1 end1 start2)
    (string-prefix? s1 s2 start1 end1 start2 (string-length s2)))
   ((s1 s2 start1 end1 start2 end2)
    (string-prefix? (substring/cursors s1 start1 end1)
                    (substring/cursors s2 start2 end2)))))

(define string-suffix?
  (case-lambda
   ((s1 s2)
    (= (string-length s1) (string-suffix-length s1 s2)))
   ((s1 s2 start1)
    (string-suffix? s1 s2 start1 (string-length s1) 0 (string-length s2)))
   ((s1 s2 start1 end1)
    (string-suffix? s1 s2 start1 end1 0 (string-length s2)))
   ((s1 s2 start1 end1 start2)
    (string-suffix? s1 s2 start1 end1 start2 (string-length s2)))
   ((s1 s2 start1 end1 start2 end2)
    (string-suffix? (substring/cursors s1 start1 end1)
                    (substring/cursors s2 start2 end2)))))

(define (string-index str pred . o)
  (apply string-find str pred (cursor-args str o)))
(define (string-index-right str pred . o)
  (apply string-find-right str pred (cursor-args str o)))

(define (string-contains s1 s2 . o)
  (let ((start1 (cursor-arg s1 (if (pair? o) (car o) (string-cursor-start s1))))
        (end1 (cursor-arg s1 (if (and (pair? o) (pair? (cdr o)))
                                 (cadr o)
                                 (string-cursor-end s1))))
        (s2 (if (and (pair? o) (pair? (cdr o))) (string-arg s2 (cddr o)) s2)))
    (let ((res (%string-contains s1 s2 start1)))
      (and res
           (string-cursor<=? (string-cursor-forward s1 res (string-length s2))
                             end1)
           res))))

(define (string-contains-right s1 s2 . o)
  (let* ((start1
          (cursor-arg s1 (if (pair? o) (car o) (string-cursor-start s1))))
         (end1 (cursor-arg s1 (if (and (pair? o) (pair? (cdr o)))
                                  (cadr o)
                                  (string-cursor-end s1))))
         (s2 (if (and (pair? o) (pair? (cdr o))) (string-arg s2 (cddr o)) s2))
         (start2 (string-cursor-start s2))
         (end2 (string-cursor-end s2)))
    (let lp ((sc1-base end1)
             (sc1 end1)
             (sc2-base end2)
             (sc2 end2))
      (cond
       ((string-cursor=? sc2 start2)
        sc1)
       ((string-cursor=? sc1 start1)
        #f)
       (else
        (let ((sc1 (string-cursor-prev s1 sc1))
              (sc2 (string-cursor-prev s2 sc2)))
          (if (eqv? (string-cursor-ref s1 sc1) (string-cursor-ref s2 sc2))
              (lp sc1-base sc1 sc2-base sc2)
              (let ((sc1-base (string-cursor-prev s1 sc1-base)))
                (lp sc1-base sc1-base sc2-base sc2-base)))))))))

(define (string-reverse str . o)
  (list->string (reverse (string->list/cursors (string-arg str o)))))

;;; The following definition is commented out because it doesn't work.
;;; In foof-string.scm, %string-join is defined to be the same as
;;; string-concatenate, creating a circularity that probably won't
;;; be detected until run time.

;(define string-concatenate %string-join)

;;; FIXME: The following definition is correct, but may not work on
;;; some systems when there are many strings in the list.

(define (string-concatenate strings)
  (cond ((null? strings)
         (make-string 0))
        ((null? (cdr strings))
         (string-copy (car strings)))
        (else
         (apply string-append strings))))

(define (string-concatenate-reverse str-ls . o)
  (let ((str-ls
         (if (pair? o)
             (cons (apply string-copy/cursors (car o) 0 (cdr o)) str-ls)
             str-ls)))
    (string-concatenate (reverse str-ls))))

(define (string-fold kons knil str . o)
  (%string-fold kons knil (string-arg str o)))

(define (string-fold-right kons knil str . o)
  (%string-fold-right kons knil (string-arg str o)))

(define (string-for-each-cursor proc str . o)
  (let ((end (cursor-arg str
                         (if (and (pair? o) (pair? (cdr o)))
                             (cadr o)
                             (string-cursor-end str)))))
    (let lp ((i (cursor-arg str
                            (if (pair? o) (car o) (string-cursor-start str)))))
      (when (string-cursor<? i end)
        (proc i)
        (lp (string-cursor-next str i))))))

(define (string-replicate str from to . o)
  (let* ((str (string-arg str o))
         (start (string-cursor-start str))
         (end (string-cursor-end str))
         (out (open-output-string)))
    (let lp ((i from)
             (sc (string-cursor-forward str
                                        start
                                        (modulo from (string-length str)))))
      (cond
       ((= i to)
        (get-output-string out))
       (else
        (write-char (string-cursor-ref str sc) out)
        (let ((sc (string-cursor-next str sc)))
          (lp (+ i 1) (if (string-cursor=? sc end) start sc))))))))

(define (string-count str pred . o)
  (apply string-fold (lambda (ch n) (if (pred ch) (+ n 1) n)) 0 str o))

(define (string-replace s1 s2 start1 end1 . o)
  (string-append (substring/cursors s1 0 start1)
                 (string-arg s2 o)
                 (substring/cursors s1 end1 (string-cursor-end s1))))

(define (string-split str delim . o)
  (let* ((delim-len (string-length delim))
         (grammar (if (pair? o) (car o) 'infix))
         (o (if (pair? o) (cdr o) '()))
         (limit (or (and (pair? o) (car o)) (string-length str)))
         (o (if (pair? o) (cdr o) '()))
         (start (cursor-arg str
                            (if (pair? o) (car o) (string-cursor-start str))))
         (end (cursor-arg str (if (and (pair? o) (pair? (cdr o)))
                                  (cadr o)
                                  (string-cursor-end str)))))
    (if (and (eq? grammar 'strict-infix) (string-cursor>=? start end))
        (error "string-split 'strict-infix called on an empty string"))
    (let ((res
           (if (= 0 delim-len)
               (map string
                    (string->list (substring/cursors str start end)))
               (let lp ((sc start) (i 0) (res '()))
                 (cond
                  ((string-cursor>=? sc end)
                   (reverse res))
                  ((and (< i limit) (string-contains str delim sc end))
                   => (lambda (sc2)
                        (let ((sc3 (string-cursor-forward str sc2 delim-len)))
                          (lp sc3
                              (+ i 1)
                              (let ((res (cons (substring-cursor str sc sc2)
                                               res)))
                                (if (string-cursor=? sc3 end)
                                    (cons "" res)
                                    res))))))
                  (else
                   (lp end i (cons (substring-cursor str sc end) res))))))))
      (case grammar
       ((prefix)
        (if (and (pair? res) (= 0 (string-length (car res))))
            (cdr res)
            res))
       ((suffix)
        (if (and (pair? res) (= 0 (string-length (car (reverse res)))))
            (reverse (cdr (reverse res)))
            res))
       (else res)))))


(define (string-filter pred str . o)
  (let ((out (open-output-string)))
    (apply string-fold (lambda (ch acc) (if (pred ch) (write-char ch out))) #f str o)
    (get-output-string out)))

(define (string-remove pred str . o)
  (apply string-filter (lambda (ch) (not (pred ch))) str o))