chibi-scheme/lib/srfi/130.scm

(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 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 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)))
    (call-with-values (lambda () (string-mismatch s1 s2))
      (lambda (i j) (string-cursor->index s1 i)))))
(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 (call-with-values (lambda () (string-mismatch-right s2 s1))
                     (lambda (i j) j))))
    (string-cursor-diff s1
                        (string-cursor-next s1 mismatch)
                        (string-cursor-end s1))))

(define (string-prefix? s1 s2 . o)
  (equal? (string-length s1) (apply string-prefix-length s1 s2 o)))
(define (string-suffix? s1 s2 . o)
  (equal? (string-length s1) (apply string-suffix-length s1 s2 o)))

(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)))))

(define string-concatenate %string-join)

(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)
  (if (string-cursor? start1)
      (string-append (substring/cursors s1 (string-cursor-start s1) start1)
                     (string-arg s2 o)
                     (substring/cursors s1 end1 (string-cursor-end s1)))
      (string-append (substring s1 0 start1)
                     (string-arg s2 o)
                     (substring s1 end1 (string-length 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) '()))
         ;; default to an arbitrary limit guaranteed to be more than
         ;; the maximum number of matches
         (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 lp ((sc start) (found? #f) (i 1) (res '()))
      (cond
       ((string-cursor>=? sc end)
        (if (and found? (not (eq? 'suffix grammar)))
            (reverse (cons "" res))
            (reverse res)))
       ((string-contains str delim sc end)
        => (lambda (sc2)
             (let ((sc3 (string-cursor-forward str sc2 delim-len)))
               (cond
                ((>= i limit)
                 (let* ((res (if (equal? "" delim)
                                 res
                                 (cons (substring-cursor str sc sc2) res)))
                        (res (if (and (string-cursor=? sc3 end)
                                      (eq? 'suffix grammar))
                                 res
                                 (cons (substring-cursor str sc3 end) res))))
                   (lp end #f i res)))
                ((equal? "" delim)
                 (lp (string-cursor-forward str sc2 1)
                     #f
                     (+ i 1)
                     (cons (string (string-cursor-ref str sc2)) res)))
                ((and (string-cursor=? sc2 start) (eq? 'prefix grammar))
                 (lp sc3 #t (+ i 1) res))
                (else
                 (lp sc3 #t (+ i 1)
                     (cons (substring-cursor str sc sc2) res)))))))
       (else
        (lp end #f i (cons (substring-cursor str sc end) 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))