(import (chicken string) (chicken format) srfi-13 srfi-14 test)

(define (fill text)
  (let* ((len (string-length text))
         (max-text-len 60)
         (last-col 70)
         (text (if (> len max-text-len)
                   (begin
                     (set! len max-text-len)
                     (substring text 0 max-text-len))
                   text)))
    (string-append text (make-string (- last-col len) #\.))))

; Tests for SRFI-13 as implemented by the Gauche scheme system.
;;
;;   Copyright (c) 2000-2003 Shiro Kawai, All rights reserved.
;;
;;   Redistribution and use in source and binary forms, with or without
;;   modification, are permitted provided that the following conditions
;;   are met:
;;
;;    1. Redistributions of source code must retain the above copyright
;;       notice, this list of conditions and the following disclaimer.
;;
;;    2. Redistributions in binary form must reproduce the above copyright
;;       notice, this list of conditions and the following disclaimer in the
;;       documentation and/or other materials provided with the distribution.
;;
;;    3. Neither the name of the authors nor the names of its contributors
;;       may be used to endorse or promote products derived from this
;;       software without specific prior written permission.
;;
;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;
;; See http://sourceforge.net/projects/gauche/

(test-begin "SRFI-13")

(test "string-null?" #f (string-null? "abc"))
(test "string-null?" #t (string-null? ""))
(test "string-every" #t (string-every #\a ""))
(test "string-every" #t (string-every #\a "aaaa"))
(test "string-every" #f (string-every #\a "aaba"))
(test "string-every" #t (string-every char-set:lower-case "aaba"))
(test "string-every" #f (string-every char-set:lower-case "aAba"))
(test "string-every" #t (string-every char-set:lower-case ""))
(test "string-every" #t (string-every (lambda (x) (char-ci=? x #\a)) "aAaA"))
(test "string-every" #f (string-every (lambda (x) (char-ci=? x #\a)) "aAbA"))
(test "string-every" (char->integer #\A)
       (string-every (lambda (x) (char->integer x)) "aAbA"))
(test "string-every" #t
       (string-every (lambda (x) (error "hoge")) ""))
(test "string-any" #t (string-any #\a "aaaa"))
(test "string-any" #f (string-any #\a "Abcd"))
(test "string-any" #f (string-any #\a ""))
(test "string-any" #t (string-any char-set:lower-case "ABcD"))
(test "string-any" #f (string-any char-set:lower-case "ABCD"))
(test "string-any" #f (string-any char-set:lower-case ""))
(test "string-any" #t (string-any (lambda (x) (char-ci=? x #\a)) "CAaA"))
(test "string-any" #f (string-any (lambda (x) (char-ci=? x #\a)) "ZBRC"))
(test "string-any" #f (string-any (lambda (x) (char-ci=? x #\a)) ""))
(test "string-any" (char->integer #\a)
       (string-any (lambda (x) (char->integer x)) "aAbA"))
(test "string-tabulate" "0123456789"
       (string-tabulate (lambda (code)
                          (integer->char (+ code (char->integer #\0))))
                        10))
(test "string-tabulate" ""
       (string-tabulate (lambda (code)
                          (integer->char (+ code (char->integer #\0))))
                        0))
(test "reverse-list->string" "cBa"
       (reverse-list->string '(#\a #\B #\c)))
(test "reverse-list->string" ""
       (reverse-list->string '()))
; string-join : Gauche builtin.
(test "substring/shared" "cde" (substring/shared "abcde" 2))
(test "substring/shared" "cd"  (substring/shared "abcde" 2 4))
(test "string-copy!" "abCDEfg"
       (let ((x (string-copy "abcdefg")))
         (string-copy! x 2 "CDE")
         x))
(test "string-copy!" "abCDEfg"
       (let ((x (string-copy "abcdefg")))
         (string-copy! x 2 "ZABCDE" 3)
         x))
(test "string-copy!" "abCDEfg"
       (let ((x (string-copy "abcdefg")))
         (string-copy! x 2 "ZABCDEFG" 3 6)
         x))

;; From Guile.  Thanks to Mark H Weaver.
(test "string-copy!: overlapping src and dest, moving right"
      "aabce"
      (let ((str (string-copy "abcde")))
	(string-copy! str 1 str 0 3) str))

(test "string-copy!: overlapping src and dest, moving left"
      "bcdde"
      (let ((str (string-copy "abcde")))
	(string-copy! str 0 str 1 4) str))

(test "string-take" "Pete S"  (string-take "Pete Szilagyi" 6))
(test "string-take" ""        (string-take "Pete Szilagyi" 0))
(test "string-take" "Pete Szilagyi" (string-take "Pete Szilagyi" 13))
(test "string-drop" "zilagyi" (string-drop "Pete Szilagyi" 6))
(test "string-drop" "Pete Szilagyi" (string-drop "Pete Szilagyi" 0))
(test "string-drop" ""        (string-drop "Pete Szilagyi" 13))

(test "string-take-right" "rules" (string-take-right "Beta rules" 5))
(test "string-take-right" ""      (string-take-right "Beta rules" 0))
(test "string-take-right" "Beta rules" (string-take-right "Beta rules" 10))
(test "string-drop-right" "Beta " (string-drop-right "Beta rules" 5))
(test "string-drop-right" "Beta rules" (string-drop-right "Beta rules" 0))
(test "string-drop-right" ""      (string-drop-right "Beta rules" 10))

(test "string-pad" "  325" (string-pad "325" 5))
(test "string-pad" "71325" (string-pad "71325" 5))
(test "string-pad" "71325" (string-pad "8871325" 5))
(test "string-pad" "~~325" (string-pad "325" 5 #\~))
(test "string-pad" "~~~25" (string-pad "325" 5 #\~ 1))
(test "string-pad" "~~~~2" (string-pad "325" 5 #\~ 1 2))
(test "string-pad-right" "325  " (string-pad-right "325" 5))
(test "string-pad-right" "71325" (string-pad-right "71325" 5))
(test "string-pad-right" "88713" (string-pad-right "8871325" 5))
(test "string-pad-right" "325~~" (string-pad-right "325" 5 #\~))
(test "string-pad-right" "25~~~" (string-pad-right "325" 5 #\~ 1))
(test "string-pad-right" "2~~~~" (string-pad-right "325" 5 #\~ 1 2))

(test "string-trim"  "a b c d  \n"
       (string-trim "  \t  a b c d  \n"))
(test "string-trim"  "\t  a b c d  \n"
       (string-trim "  \t  a b c d  \n" #\space))
(test "string-trim"  "a b c d  \n"
       (string-trim "4358948a b c d  \n" char-set:digit))

(test "string-trim-right"  "  \t  a b c d"
       (string-trim-right "  \t  a b c d  \n"))
(test "string-trim-right"  "  \t  a b c d  "
       (string-trim-right "  \t  a b c d  \n" (char-set #\newline)))
(test "string-trim-right"  "349853a b c d"
       (string-trim-right "349853a b c d03490" char-set:digit))

(test "string-trim-both"  "a b c d"
       (string-trim-both "  \t  a b c d  \n"))
(test "string-trim-both"  "  \t  a b c d  "
       (string-trim-both "  \t  a b c d  \n" (char-set #\newline)))
(test "string-trim-both"  "a b c d"
       (string-trim-both "349853a b c d03490" char-set:digit))

;; string-fill - in string.scm

(test "string-compare" 5
       (string-compare "The cat in the hat" "abcdefgh"
                       values values values
                       4 6 2 4))
(test "string-compare-ci" 5
       (string-compare-ci "The cat in the hat" "ABCDEFGH"
                          values values values
                          4 6 2 4))

;; TODO: bunch of string= families

(test "string-prefix-length" 5
       (string-prefix-length "cancaNCAM" "cancancan"))
(test "string-prefix-length-ci" 8
       (string-prefix-length-ci "cancaNCAM" "cancancan"))
(test "string-suffix-length" 2
       (string-suffix-length "CanCan" "cankancan"))
(test "string-suffix-length-ci" 5
       (string-suffix-length-ci "CanCan" "cankancan"))

(test "string-prefix?" #t    (string-prefix? "abcd" "abcdefg"))
(test "string-prefix?" #f    (string-prefix? "abcf" "abcdefg"))
(test "string-prefix-ci?" #t (string-prefix-ci? "abcd" "aBCDEfg"))
(test "string-prefix-ci?" #f (string-prefix-ci? "abcf" "aBCDEfg"))
(test "string-suffix?" #t    (string-suffix? "defg" "abcdefg"))
(test "string-suffix?" #f    (string-suffix? "aefg" "abcdefg"))
(test "string-suffix-ci?" #t (string-suffix-ci? "defg" "aBCDEfg"))
(test "string-suffix-ci?" #f (string-suffix-ci? "aefg" "aBCDEfg"))

(test "string-index #1" 4
       (string-index "abcd:efgh:ijkl" #\:))
(test "string-index #2" 4
       (string-index "abcd:efgh;ijkl" (char-set-complement char-set:letter)))
(test "string-index #3" #f
       (string-index "abcd:efgh;ijkl" char-set:digit))
(test "string-index #4" 9
       (string-index "abcd:efgh:ijkl" #\: 5))
(test "string-index-right #1" 4
       (string-index-right "abcd:efgh;ijkl" #\:))
(test "string-index-right #2" 9
       (string-index-right "abcd:efgh;ijkl" (char-set-complement char-set:letter)))
(test "string-index-right #3" #f
       (string-index-right "abcd:efgh;ijkl" char-set:digit))
(test "string-index-right #4" 4
       (string-index-right "abcd:efgh;ijkl" (char-set-complement char-set:letter) 2 5))

(test "string-count #1" 2
       (string-count "abc def\tghi jkl" #\space))
(test "string-count #2" 3
       (string-count "abc def\tghi jkl" char-set:whitespace))
(test "string-count #3" 2
       (string-count "abc def\tghi jkl" char-set:whitespace 4))
(test "string-count #4" 1
       (string-count "abc def\tghi jkl" char-set:whitespace 4 9))
(test "string-contains" 3
       (string-contains "Ma mere l'oye" "mer"))
(test "string-contains" #f
       (string-contains "Ma mere l'oye" "Mer"))
(test "string-contains-ci" 3
       (string-contains-ci "Ma mere l'oye" "Mer"))
(test "string-contains-ci" #f
       (string-contains-ci "Ma mere l'oye" "Meer"))

(test "string-titlecase" "--Capitalize This Sentence."
       (string-titlecase "--capitalize tHIS sentence."))
(test "string-titlecase" "3Com Makes Routers."
       (string-titlecase "3com makes routers."))
(test "string-titlecase!" "alSo Whatever"
       (let ((s (string-copy "also whatever")))
         (string-titlecase! s 2 9)
         s))

(test "string-upcase" "SPEAK LOUDLY"
       (string-upcase "speak loudly"))
(test "string-upcase" "PEAK"
       (string-upcase "speak loudly" 1 5))
(test "string-upcase!" "sPEAK loudly"
       (let ((s (string-copy "speak loudly")))
         (string-upcase! s 1 5)
         s))

(test "string-downcase" "speak softly"
       (string-downcase "SPEAK SOFTLY"))
(test "string-downcase" "peak"
       (string-downcase "SPEAK SOFTLY" 1 5))
(test "string-downcase!" "Speak SOFTLY"
       (let ((s (string-copy "SPEAK SOFTLY")))
         (string-downcase! s 1 5)
         s))

(test "string-reverse" "nomel on nolem on"
       (string-reverse "no melon no lemon"))
(test "string-reverse" "nomel on"
       (string-reverse "no melon no lemon" 9))
(test "string-reverse" "on"
       (string-reverse "no melon no lemon" 9 11))
(test "string-reverse!" "nomel on nolem on"
       (let ((s (string-copy "no melon no lemon")))
         (string-reverse! s) s))
(test "string-reverse!" "no melon nomel on"
       (let ((s (string-copy "no melon no lemon")))
         (string-reverse! s 9) s))
(test "string-reverse!" "no melon on lemon"
       (let ((s (string-copy "no melon no lemon")))
         (string-reverse! s 9 11) s))

(test "string-append" #f
       (let ((s "test")) (eq? s (string-append s))))
(test "string-concatenate" #f
       (let ((s "test")) (eq? s (string-concatenate (list s)))))
(test "string-concatenate" "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
       (string-concatenate
        '("A" "B" "C" "D" "E" "F" "G" "H"
          "I" "J" "K" "L" "M" "N" "O" "P"
          "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z"
          "a" "b" "c" "d" "e" "f" "g" "h"
          "i" "j" "k" "l" "m" "n" "o" "p"
          "q" "r" "s" "t" "u" "v" "w" "x" "y" "z")))
(test "string-concatenate/shared" "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
       (string-concatenate/shared
        '("A" "B" "C" "D" "E" "F" "G" "H"
          "I" "J" "K" "L" "M" "N" "O" "P"
          "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z"
          "a" "b" "c" "d" "e" "f" "g" "h"
          "i" "j" "k" "l" "m" "n" "o" "p"
          "q" "r" "s" "t" "u" "v" "w" "x" "y" "z")))
(test "string-concatenate-reverse" "zyxwvutsrqponmlkjihgfedcbaZYXWVUTSRQPONMLKJIHGFEDCBA"
       (string-concatenate-reverse
        '("A" "B" "C" "D" "E" "F" "G" "H"
          "I" "J" "K" "L" "M" "N" "O" "P"
          "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z"
          "a" "b" "c" "d" "e" "f" "g" "h"
          "i" "j" "k" "l" "m" "n" "o" "p"
          "q" "r" "s" "t" "u" "v" "w" "x" "y" "z")))
(test "string-concatenate-reverse" #f
       (let ((s "test"))
         (eq? s (string-concatenate-reverse (list s)))))
(test "string-concatenate-reverse/shared" "zyxwvutsrqponmlkjihgfedcbaZYXWVUTSRQPONMLKJIHGFEDCBA"
       (string-concatenate-reverse/shared
        '("A" "B" "C" "D" "E" "F" "G" "H"
          "I" "J" "K" "L" "M" "N" "O" "P"
          "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z"
          "a" "b" "c" "d" "e" "f" "g" "h"
          "i" "j" "k" "l" "m" "n" "o" "p"
          "q" "r" "s" "t" "u" "v" "w" "x" "y" "z")))

(test "string-map" "svool"
       (string-map (lambda (c)
                     (integer->char (- 219 (char->integer c))))
                   "hello"))
(test "string-map" "vool"
       (string-map (lambda (c)
                     (integer->char (- 219 (char->integer c))))
                   "hello" 1))
(test "string-map" "vo"
       (string-map (lambda (c)
                     (integer->char (- 219 (char->integer c))))
                   "hello" 1 3))
(test "string-map!" "svool"
       (let ((s (string-copy "hello")))
         (string-map! (lambda (c)
                        (integer->char (- 219 (char->integer c))))
                      s)
         s))
(test "string-map!" "hvool"
       (let ((s (string-copy "hello")))
         (string-map! (lambda (c)
                        (integer->char (- 219 (char->integer c))))
                      s 1)
         s))
(test "string-map!" "hvolo"
       (let ((s (string-copy "hello")))
         (string-map! (lambda (c)
                        (integer->char (- 219 (char->integer c))))
                      s 1 3)
         s))

(test "string-fold" '(#\o #\l #\l #\e #\h . #t)
       (string-fold cons #t "hello"))
(test "string-fold" '(#\l #\e . #t)
       (string-fold cons #t "hello" 1 3))
(test "string-fold-right" '(#\h #\e #\l #\l #\o . #t)
       (string-fold-right cons #t "hello"))
(test "string-fold-right" '(#\e #\l . #t)
       (string-fold-right cons #t "hello" 1 3))

(test "string-unfold" "hello"
       (string-unfold null? car cdr '(#\h #\e #\l #\l #\o)))
(test "string-unfold" "hi hello"
       (string-unfold null? car cdr '(#\h #\e #\l #\l #\o) "hi "))
(test "string-unfold" "hi hello ho"
       (string-unfold null? car cdr
                      '(#\h #\e #\l #\l #\o) "hi "
                      (lambda (x) " ho")))

(test "string-unfold-right" "olleh"
       (string-unfold-right null? car cdr '(#\h #\e #\l #\l #\o)))
(test "string-unfold-right" "olleh hi"
       (string-unfold-right null? car cdr '(#\h #\e #\l #\l #\o) " hi"))
(test "string-unfold-right" "ho olleh hi"
       (string-unfold-right null? car cdr
                            '(#\h #\e #\l #\l #\o) " hi"
                            (lambda (x) "ho ")))

(test "string-for-each" "CLtL"
       (let ((out (open-output-string))
             (prev #f))
         (string-for-each (lambda (c)
                            (if (or (not prev)
                                    (char-whitespace? prev))
                                (write-char c out))
                            (set! prev c))
                          "Common Lisp, the Language")

         (get-output-string out)))
(test "string-for-each" "oLtL"
       (let ((out (open-output-string))
             (prev #f))
         (string-for-each (lambda (c)
                            (if (or (not prev)
                                    (char-whitespace? prev))
                                (write-char c out))
                            (set! prev c))
                          "Common Lisp, the Language" 1)
         (get-output-string out)))
(test "string-for-each" "oL"
       (let ((out (open-output-string))
             (prev #f))
         (string-for-each (lambda (c)
                            (if (or (not prev)
                                    (char-whitespace? prev))
                                (write-char c out))
                            (set! prev c))
                          "Common Lisp, the Language" 1 10)
         (get-output-string out)))
(test "string-for-each-index" '(4 3 2 1 0)
       (let ((r '()))
         (string-for-each-index (lambda (i) (set! r (cons i r))) "hello")
         r))
(test "string-for-each-index" '(4 3 2 1)
       (let ((r '()))
         (string-for-each-index (lambda (i) (set! r (cons i r))) "hello" 1)
         r))
(test "string-for-each-index" '(2 1)
       (let ((r '()))
         (string-for-each-index (lambda (i) (set! r (cons i r))) "hello" 1 3)
         r))

(test "xsubstring" "cdefab"
       (xsubstring "abcdef" 2))
(test "xsubstring" "efabcd"
       (xsubstring "abcdef" -2))
(test "xsubstring" "abcabca"
       (xsubstring "abc" 0 7))
;; (test "xsubstring" "abcabca"
;;        (xsubstring "abc"
;;                    30000000000000000000000000000000
;;                    30000000000000000000000000000007))
(test "xsubstring" "defdefd"
       (xsubstring "abcdefg" 0 7 3 6))
(test "xsubstring" ""
       (xsubstring "abcdefg" 9 9 3 6))

(test "string-xcopy!" "ZZcdefabZZ"
       (let ((s (make-string 10 #\Z)))
         (string-xcopy! s 2 "abcdef" 2)
         s))
(test "string-xcopy!" "ZZdefdefZZ"
       (let ((s (make-string 10 #\Z)))
         (string-xcopy! s 2 "abcdef" 0 6 3)
         s))

(test "string-replace" "abcdXYZghi"
       (string-replace "abcdefghi" "XYZ" 4 6))
(test "string-replace" "abcdZghi"
       (string-replace "abcdefghi" "XYZ" 4 6 2))
(test "string-replace" "abcdZefghi"
       (string-replace "abcdefghi" "XYZ" 4 4 2))
(test "string-replace" "abcdefghi"
       (string-replace "abcdefghi" "XYZ" 4 4 1 1))
(test "string-replace" "abcdhi"
       (string-replace "abcdefghi" "" 4 7))

(test "string-tokenize" '("Help" "make" "programs" "run," "run," "RUN!")
       (string-tokenize "Help make programs run, run, RUN!"))
(test "string-tokenize" '("Help" "make" "programs" "run" "run" "RUN")
       (string-tokenize "Help make programs run, run, RUN!"
                        char-set:letter))
(test "string-tokenize" '("programs" "run" "run" "RUN")
       (string-tokenize "Help make programs run, run, RUN!"
                        char-set:letter 10))
(test "string-tokenize" '("elp" "make" "programs" "run" "run")
       (string-tokenize "Help make programs run, run, RUN!"
                        char-set:lower-case))

(test "string-filter" "rrrr"
       (string-filter #\r "Help make programs run, run, RUN!"))
(test "string-filter" "HelpmakeprogramsrunrunRUN"
       (string-filter char-set:letter "Help make programs run, run, RUN!"))

(test "string-filter" "programsrunrun"
       (string-filter (lambda (c) (char-lower-case? c))
                      "Help make programs run, run, RUN!"
                      10))
(test "string-filter" ""
       (string-filter (lambda (c) (char-lower-case? c)) ""))
(test "string-delete" "Help make pogams un, un, RUN!"
       (string-delete #\r "Help make programs run, run, RUN!"))
(test "string-delete" "   , , !"
       (string-delete char-set:letter "Help make programs run, run, RUN!"))
(test "string-delete" " , , RUN!"
       (string-delete (lambda (c) (char-lower-case? c))
                      "Help make programs run, run, RUN!"
                      10))
(test "string-delete" ""
       (string-delete (lambda (c) (char-lower-case? c)) ""))

;;; Additional tests so that the suite at least touches all
;;; the functions.

(test "string-hash" #t (<= 0 (string-hash "abracadabra" 20) 19))

(test "string-hash" #t (= (string-hash "abracadabra" 20) (string-hash "abracadabra" 20)))

(test "string-hash" #t (= (string-hash "abracadabra" 20 2 7)
                          (string-hash (substring "abracadabra" 2 7) 20)))

(test "string-hash-ci" #t (= (string-hash-ci "aBrAcAdAbRa" 20)
                             (string-hash-ci "AbRaCaDaBrA" 20)))

(test "string-hash-ci" #t (= (string-hash-ci "aBrAcAdAbRa" 20 2 7)
                             (string-hash-ci (substring "AbRaCaDaBrA" 2 7) 20)))

(test "string=" #t (string= "foo" "foo"))
(test "string=" #t (string= "foobar" "foo" 0 3))
(test "string=" #t (string= "foobar" "barfoo" 0 3 3))
(test "string=" #t (not (string= "foobar" "barfoo" 0 3 2 5)))

(test "string<>" #t (string<> "flo" "foo"))
(test "string<>" #t (string<> "flobar" "foo" 0 3))
(test "string<>" #t (string<> "flobar" "barfoo" 0 3 3))
(test "string<>" #t (not (string<> "foobar" "foobar" 0 3 0 3)))

(test "string<=" #t (string<= "fol" "foo"))
(test "string<=" #t (string<= "folbar" "foo" 0 3))
(test "string<=" #t (string<= "foobar" "barfoo" 0 3 3))
(test "string<=" #f (string<= "foobar" "barfoo" 0 3 1 4))

(test "string<" #t (string< "fol" "foo"))
(test "string<" #t (string< "folbar" "foo" 0 3))
(test "string<" #t (string< "folbar" "barfoo" 0 3 3))
(test "string<" #t (not (string< "foobar" "barfoo" 0 3 1 4)))

(test "string>=" #t (string>= "foo" "fol"))
(test "string>=" #t (string>= "foo" "folbar" 0 3 0 3))
(test "string>=" #t (string>= "barfoo" "foo" 3 6 0))
(test "string>=" #t (not (string>= "barfoo" "foobar" 1 4 0 3)))

(test "string>" #t (string> "foo" "fol"))
(test "string>" #t (string> "foo" "folbar" 0 3 0 3))
(test "string>" #t (string> "barfoo" "fol" 3 6 0))
(test "string>" #t (not (string> "barfoo" "foobar" 1 4 0 3)))

(test "string-ci=" #t (string-ci= "Foo" "foO"))
(test "string-ci=" #t (string-ci= "Foobar" "fOo" 0 3))
(test "string-ci=" #t (string-ci= "Foobar" "bArfOo" 0 3 3))
(test "string-ci=" #t (not (string-ci= "foobar" "BARFOO" 0 3 2 5)))

(test "string-ci<>" #t (string-ci<> "flo" "FOO"))
(test "string-ci<>" #t (string-ci<> "FLOBAR" "foo" 0 3))
(test "string-ci<>" #t (string-ci<> "flobar" "BARFOO" 0 3 3))
(test "string-ci<>" #t (not (string-ci<> "foobar" "FOOBAR" 0 3 0 3)))

(test "string-ci<=" #t (string-ci<= "FOL" "foo"))
(test "string-ci<=" #t (string-ci<= "folBAR" "fOO" 0 3))
(test "string-ci<=" #t (string-ci<= "fOOBAR" "BARFOO" 0 3 3))
(test "string-ci<=" #t (not (string-ci<= "foobar" "BARFOO" 0 3 1 4)))

(test "string-ci<" #t (string-ci< "fol" "FOO"))
(test "string-ci<" #t (string-ci< "folbar" "FOO" 0 3))
(test "string-ci<" #t (string-ci< "folbar" "BARFOO" 0 3 3))
(test "string-ci<" #t (not (string-ci< "foobar" "BARFOO" 0 3 1 4)))

(test "string-ci>=" #t (string-ci>= "FOO" "fol"))
(test "string-ci>=" #t (string-ci>= "foo" "FOLBAR" 0 3 0 3))
(test "string-ci>=" #t (string-ci>= "BARFOO" "foo" 3 6 0))
(test "string-ci>=" #t (not (string-ci>= "barfoo" "FOOBAR" 1 4 0 3)))

(test "string-ci>" #t (string-ci> "FOO" "fol"))
(test "string-ci>" #t (string-ci> "foo" "FOLBAR" 0 3 0 3))
(test "string-ci>" #t (string-ci> "barfoo" "FOL" 3 6 0))
(test "string-ci>" #t (not (string-ci> "barfoo" "FOOBAR" 1 4 0 3)))

(test "string=?" #t (string=? "abcd" (string-append/shared "a" "b" "c" "d")))

(test "string-parse-start+end"
      #t
      (let-values (((rest start end) (string-parse-start+end #t "foo" '(1 3 fnord))))
        (and (= start 1)
             (= end 3)
             (equal? rest '(fnord)))))

(test "string-parse-start+end"
      #t
      (call-with-current-continuation
       (lambda (k)
         (handle-exceptions exn
           (k #t)
           (string-parse-start+end #t "foo" '(1 4))
           #f))))

(test "string-parse-start+end"
      #t
      (let-values (((start end) (string-parse-final-start+end #t "foo" '(1 3))))
        (and (= start 1)
             (= end 3))))

(test "string-parse-start+end"
      #t
      (let-string-start+end (start end rest) #t "foo" '(1 3 fnord)
                            (and (= start 1)
                                 (= end 3)
                                 (equal? rest '(fnord)))))

(test-assert "check-substring-spec" (check-substring-spec #t "foo" 1 3))

(test-assert "check-substring-spec"
             (call-with-current-continuation
              (lambda (k)
                (handle-exceptions exn
                  (k #t)
                  (check-substring-spec #t "foo" 1 4)
                  #f))))

(test-assert "substring-spec-ok?" (substring-spec-ok? "foo" 1 3))

(test-assert "substring-spec-ok?" (not (substring-spec-ok? "foo" 1 4)))

(test "make-kmp-restart-vector" '#() (make-kmp-restart-vector ""))

(test "make-kmp-restart-vector" '#(-1) (make-kmp-restart-vector "a"))

(test "make-kmp-restart-vector" '#(-1 0) (make-kmp-restart-vector "ab"))

; The following is from an example in the code.  It is the "optimised"
; version; it's also valid to return #(-1 0 0 0 1 2), but that will
; needlessly check the "a" twice before giving up.
(test "make-kmp-restart-vector"
      '#(-1 0 0 -1 1 2)
      (make-kmp-restart-vector "abdabx"))

;; Each entry in kmp-cases is a pattern, a string to match against and
;; the expected run of the algorithm through the positions in the
;; pattern.  So for example 0 1 2 means it looks at position 0 first,
;; then at 1 and then at 2.
;;
;; This is easy to verify in simple cases; If there's a shared
;; substring and matching fails, you try matching again starting at
;; the end of the shared substring, otherwise you rewind.  For more
;; complex cases, it's increasingly difficult for humans to verify :)
(define kmp-cases
  '(("abc" "xx" #f 0 0)
    ("abc" "abc" #t 0 1 2)
    ("abcd" "abc" #f 0 1 2)
    ("abc" "abcd" #t 0 1 2)
    ("abc" "aabc" #t 0 1 1 2)
    ("ab" "aa" #f 0 1)
    ("ab" "aab" #t 0 1 1)
    ("abdabx" "abdbbabda" #f 0 1 2 3 0 0 1 2 3)
    ("aabc" "axaabc" #t 0 1 0 1 2 3)
    ("aabac" "aabaabac" #t 0 1 2 3 4 2 3 4)))

(for-each
 (lambda (test-case)
   (let* ((pat (car test-case))
	  (n (string-length pat))
	  (str (cadr test-case))
          (match? (caddr test-case))
	  (steps (cdddr test-case))
	  (rv (make-kmp-restart-vector pat)))
     (let ((p (open-input-string str)))
       (let lp ((i 0)
		(step 0)
		(steps steps))
	 (cond
	   ((or (= i n) (eof-object? (peek-char p)))
	    (test-assert (sprintf "KMP match? ~S, case: ~S" match? test-case)
			 (eq? (= i n) match?))
	    (test-assert (sprintf "KMP empty remaining steps: ~S, case: ~S"
			   steps test-case)
			 (null? steps)))
	   (else
	    (let ((new-i (kmp-step pat rv (read-char p) i char=? 0))
		  (expected-i (and (not (null? steps)) (car steps))))
	      (test (sprintf "KMP step ~S (exp: ~S, act: ~S), case: ~S"
		      step expected-i i test-case)
		    expected-i i)
	      (lp new-i (add1 step) (cdr steps)))))))))
 kmp-cases)

; FIXME!  Implement tests for these:
;   string-kmp-partial-search
;   kmp-step


;;; Regression tests: check that reported bugs have been fixed

; From: Matthias Radestock <matthias@sorted.org>
; Date: Wed, 10 Dec 2003 21:05:22 +0100
;
; Chris Double has found the following bug in the reference implementation:
;
;  (string-contains "xabc" "ab") => 1    ;good
;  (string-contains "aabc" "ab") => #f   ;bad
;
; Matthias.

(test "string-contains" 1 (string-contains "aabc" "ab"))

(test "string-contains" 5 (string-contains "ababdabdabxxas" "abdabx"))

(test "string-contains-ci" 1 (string-contains-ci "aabc" "ab"))

; (message continues)
;
; PS: There is also an off-by-one error in the bounds check of the
; unoptimized version of string-contains that is included as commented out
; code in the reference implementation. This breaks things like
; (string-contains "xab" "ab") and (string-contains "ab" "ab").

; This off-by-one bug has been fixed in the comments of the version
; of SRFI-13 shipped with Larceny.  In a version of the code without
; the fix the following test will catch the bug:

(test "string-contains" 0 (string-contains "ab" "ab"))

; From: dvanhorn@emba.uvm.edu
; Date: Wed, 26 Mar 2003 08:46:41 +0100
;
; The SRFI document gives,
;
;   string-filter s char/char-set/pred [start end] -> string
;   string-delete s char/char-set/pred [start end] -> string
;
; Yet the reference implementation switches the order giving,
;
;   ;;; string-delete char/char-set/pred string [start end]
;   ;;; string-filter char/char-set/pred string [start end]
;   ...
;   (define (string-delete criterion s . maybe-start+end)
;   ...
;   (define (string-filter criterion s . maybe-start+end)
;
; I reviewed the SRFI-13 mailing list and c.l.scheme, but found no mention of
; this issue.  Apologies if I've missed something.

(test-assert "string=? + string-filter"
             (call-with-current-continuation
              (lambda (k)
                (handle-exceptions exn
                  (k #f)
                  (string=? "ADR" (string-filter char-set:upper-case "abrAcaDabRa"))))))

(test-assert "string=? + string-delete"
             (call-with-current-continuation
              (lambda (k)
                (handle-exceptions exn
                  (k #f)
                  (string=? "abrcaaba" (string-delete char-set:upper-case "abrAcaDabRa"))))))


; http://srfi.schemers.org/srfi-13/post-mail-archive/msg00007.html
; From: David Van Horn <address@hidden>
; Date: Wed, 01 Nov 2006 07:53:34 +0100
;
; Both string-index-right and string-skip-right will continue to search
; left past a given start index.
;
;    (string-index-right "abbb" #\a 1) ;; => 0, but should be #f
;    (string-skip-right  "abbb" #\b 1) ;; => 0, but should be #f
;
; This also causes incorrect results for string-trim-right,
; string-trim-both and string-tokenize when given a non-zero start
; argument.

(test "string-index-right" #f (string-index-right "abbb" #\a 1))
(test "string-skip-right" #f (string-skip-right  "abbb" #\b 1))

;; Tests to check the string-trim-right issue found by Seth Alves
;; http://lists.gnu.org/archive/html/chicken-hackers/2014-01/msg00016.html
(test "string-trim-right" "" (string-trim-right "" char-whitespace? 0 0))
(test "string-trim-right" "" (string-trim-right "a" char-whitespace? 0 0))
(test "string-trim-right" "" (string-trim-right "a " char-whitespace? 0 0))
(test "string-trim-right" "bc" (string-trim-right "abc   " char-whitespace? 1))
(test "string-trim-right" "" (string-trim-right "abc   " char-whitespace? 4 4))

(test-end "SRFI-13")

(test-exit)