~ chicken-core (master) /tests/unicode-tests.scm

  1;;; unicode tests, taken from Chibi
  2
  3(import (chicken port) (chicken sort))
  4(import (chicken string) (chicken io))
  5(import (chicken bytevector))
  6(import (only (scheme base) write-string))
  7
  8(include "test.scm")
  9                           
 10(test-begin "scheme")
 11
 12(test-equal #\Р (string-ref "Русский" 0))
 13(test-equal #\и (string-ref "Русский" 5))
 14(test-equal #\й (string-ref "Русский" 6))
 15
 16(test-equal 7 (string-length "Русский"))
 17
 18(test-equal #\日 (string-ref "日本語" 0))
 19(test-equal #\本 (string-ref "日本語" 1))
 20(test-equal #\語 (string-ref "日本語" 2))
 21
 22(test-equal 3 (string-length "日本語"))
 23
 24(test-equal '(#\日 #\本 #\語) (string->list "日本語"))
 25(test-equal "日本語" (list->string '(#\日 #\本 #\語)))
 26
 27(test-equal "日本" (substring "日本語" 0 2))
 28(test-equal "本語" (substring "日本語" 1 3))
 29
 30(test-equal "日-語"
 31      (let ((s (substring "日本語" 0 3)))
 32        (string-set! s 1 #\-)
 33        s))
 34
 35(test-equal "日本人"
 36      (let ((s (substring "日本語" 0 3)))
 37        (string-set! s 2 #\人)
 38        s))
 39
 40(test-equal "字字字" (make-string 3 #\字))
 41
 42(test-equal "字字字"
 43      (let ((s (make-string 3)))
 44        (string-fill! s #\字)
 45        s))
 46
 47; tests from the utf8 egg:
 48
 49(test-equal 2 (string-length "漢字"))
 50
 51(test-equal 28450 (char->integer (string-ref "漢字" 0)))
 52
 53(define str (string-copy "漢字"))
 54
 55(test-equal "赤字" (begin (string-set! str 0 (string-ref "赤" 0)) str))
 56
 57(test-equal "赤外" (begin (string-set! str 1 (string-ref "外" 0)) str))
 58
 59(test-equal "赤x" (begin (string-set! str 1 #\x) str))
 60
 61(test-equal "赤々" (begin (string-set! str 1 (string-ref "々" 0)) str))
 62
 63(test-equal "文字列" (substring "文字列" 0))
 64(test-equal "字列" (substring "文字列" 1))
 65(test-equal "列" (substring "文字列" 2))
 66(test-equal "文" (substring "文字列" 0 1))
 67(test-equal "字" (substring "文字列" 1 2))
 68(test-equal "文字" (substring "文字列" 0 2))
 69
 70(define *string* "文字列")
 71(define *list* '("文" "字" "列"))
 72(define *chars* '(25991 23383 21015))
 73
 74(test-equal *chars* (map char->integer (string->list "文字列")))
 75
 76(test-equal *list* (map string (map integer->char *chars*)))
 77
 78(test-equal *string* (list->string (map integer->char '(25991 23383 21015))))
 79
 80(test-equal "列列列" (make-string 3 (string-ref "列" 0)))
 81
 82(test-equal "文文文" (let ((s (string-copy "abc"))) (string-fill! s (string-ref "文" 0)) s))
 83
 84(test-equal (string-ref "ﾊ" 0) (with-input-from-string "全角ﾊﾝｶｸ"
 85                           (lambda () (read-char) (read-char) (read-char))))
 86
 87(test-equal "個々" (with-output-to-string
 88              (lambda ()
 89                (write-char (string-ref "個" 0))
 90                (write-char (string-ref "々" 0)))))
 91
 92;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 93;; library
 94
 95(test-equal "出力改行\n" (with-output-to-string
 96                   (lambda () (print "出" (string-ref "力" 0) "改行"))))
 97
 98(test-equal "出力" (with-output-to-string
 99              (lambda () (print* "出" (string-ref "力" 0) ""))))
100
101(test-equal "逆リスト→文字列" (reverse-list->string
102                     (map (cut string-ref <> 0)
103                          '("列" "字" "文" "→" "ト" "ス" "リ" "逆"))))
104
105(test-error (utf8->string #u8(255 1 2)))
106(test-equal "BC" (utf8->string #u8(65 66 67) 1 3))
107(test-assert (bytes->string #u8(255 1 2)))
108(test-equal (string-length (bytes->string #u8(255 1 2))) 3)
109
110;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
111;; extras
112
113(test-equal "这是" (with-input-from-string "这是中文" (cut read-string 2)))
114
115(define s "abcdef")
116(call-with-input-string "这是中文" (cut read-string! 2 s <> 2))
117(test-equal "ab这是ef" s)
118       
119(define s "这是中文")
120(call-with-input-string "abcd" (cut read-string! 1 s <> 2))
121(test-equal "这是a文" s)
122       
123(test-equal "这是" (with-output-to-string (cut write-string "这是中文" (current-output-port) 0 2)))
124
125(test-equal "我爱她" (conc (with-input-from-string "我爱你"
126                      (cut read-token (lambda (c)
127                                        (memv c (map (cut string-ref <> 0)
128                                                     '("爱" "您" "我"))))))
129                        "她"))
130
131(test-equal '("第一" "第二" "第三") (string-chop "第一第二第三" 2))
132
133(test-equal '("第一" "第二" "第三" "…") (string-chop "第一第二第三…" 2))
134
135(test-equal '("a" "bc" "第" "f几") (string-split "a,bc、第,f几" ",、"))
136
137(test-equal "THE QUICK BROWN FOX JUMPED OVER THE LAZY SLEEPING DOG"
138    (string-translate "the quick brown fox jumped over the lazy sleeping dog"
139                      "abcdefghijklmnopqrstuvwxyz"
140                      "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
141(test-equal ":foo:bar:baz" (string-translate "/foo/bar/baz" "/" ":"))
142(test-equal "你爱我" (string-translate "我爱你" "我你" "你我"))
143(test-equal "你爱我" (string-translate "我爱你" '(#\我 #\你) '(#\你 #\我)))
144(test-equal "我你" (string-translate "我爱你" "爱"))
145(test-equal "我你" (string-translate "我爱你" #\爱))
146
147(test-assert (substring=? "日本語" "日本語"))
148(test-assert (substring=? "日本語" "日本"))
149(test-assert (substring=? "日本" "日本語"))
150(test-assert (substring=? "日本語" "本語" 1))
151(test-assert (substring=? "日本語" "本" 1 0 1))
152(test-assert (substring=? "听说上海的东西很贵" "上海的东西很便宜" 2 0 5))
153
154(test-equal 2 (substring-index "上海" "听说上海的东西很贵"))
155
156;; case folding
157
158(test-assert (string-ci=? "abc" "ABC"))
159(test-assert (string-ci=? "Xῌηιx" "xηιῌX"))
160(test-assert (string-ci=? "αβξ" "αβξ"))
161(test-assert (string-ci=? "αβξ" "ΑΒΞ"))
162
163;; Contributed by Anton Idukov:
164
165(import (scheme char))
166
167(test-equal "ru_RU(съешь ещё этих мягких французских булок, да выпей чаю.)"
168            (utf8->string
169              (string->utf8 "ru_RU(съешь ещё этих мягких французских булок, да выпей чаю.)")))
170
171
172(test-equal "Привет, МИР!"
173            (list->string (map integer->char (map char->integer (string->list "Привет, МИР!")))))
174
175
176(test-equal "ПРИВЕТ, МИР!"
177            (symbol->string
178              (string->symbol
179                (list->string
180                  (map char-upcase (string->list "Привет, МИР!"))))))
181
182
183(test-equal "DZIŚ JEST BARDZO GORĄCY DZIEŃ"
184            (list->string
185              (map char-upcase
186                   (string->list
187                     (list->string
188                       (map char-downcase
189                            (string->list "DZIŚ JEST BARDZO GORĄCY DZIEŃ")))))))
190
191
192(test-equal 7
193            (apply + (map digit-value
194                '(#\3 #\x0664 #\x0AE6))))
195
196
197(test-equal "ru_RU(съешь ещё этих мягких французских булок, да выпей чаю.)"
198            (list->string
199              (reverse
200                (string->list
201                  (list->string
202                    (reverse
203                      (string->list "ru_RU(съешь ещё этих мягких французских булок, да выпей чаю.)")))))))
204
205(test-equal #t (string<? "ABCD" "ABCd" "ABcd"))
206(test-equal #f (string-ci<? "ABCD" "ABCd" "ABcd"))
207
208(test-equal #t (string<? "АБВГ" "АБВг" "АБвг"))
209(test-equal #f (string-ci<? "АБВГ" "АБВг" "АБвг"))
210
211(test-equal #t (string>? "АБвг" "АБВг" "АБВГ"))
212(test-equal #f (string-ci>? "АБвг" "АБВг" "АБВГ"))
213
214(test-equal #t (string<=? "ПРИВЕТ" "ПРИВЕТ" "ПРИвет"))
215(test-equal #t (string-ci<=? "ПРИВЕТ" "ПРИВЕТ" "ПРИвет"))
216
217(test-equal #t (string>=? "АБвг" "АБвг" "АБВг"))
218(test-equal #t (string-ci>=? "АБвг" "АБвг" "АБВг"))
219
220(test-equal '("ЭЭЭЭЭЭЭЭ" 8)
221            (let ((s (make-string 8 #\newline)))
222              (string-fill! s #\Э)
223              (list s (string-length s))))
224
225
226(test-error (string-fill "Hello" 4 #\x))
227
228
229;; Confirm that compressed ranges in UnicodeData.txt are expanded correctly.
230
231(define (count-if pred lo hi)
232  (let loop ((i lo) (n 0))
233    (if (> i hi)
234        n
235        (loop (add1 i)
236              (if (pred (integer->char i))
237                  (add1 n)
238                  n)))))
239
240(test-equal 20992 (count-if char-alphabetic? #x4E00 #x9FFF))   ; CJK
241(test-equal 11172 (count-if char-alphabetic? #xAC00 #xD7A3))   ; Hangul
242(test-assert (> (count-if char-alphabetic? 0 #x10FFFF) 100000))
243
244
245;; Confirm that consecutive decimal digit runs are not folded together.
246
247(test-equal 0 (digit-value (integer->char #x1D7CE)))   ; bold zero
248(test-equal 0 (digit-value (integer->char #x1D7D8)))   ; double-struck zero
249(test-equal 0 (digit-value (integer->char #x1D7E2)))   ; sans-serif zero
250(test-equal 0 (digit-value (integer->char #x1D7EC)))   ; sans-serif bold zero
251(test-equal 0 (digit-value (integer->char #x1D7F6)))   ; monospace zero
252(test-equal 9 (digit-value (integer->char #x1D7FF)))   ; monospace nine
253
254;; Confirm that decimal digits are all in 0 to 9 range.
255
256(test-assert (let loop ((i 0))
257               (cond ((> i #x10FFFF) #t)
258                     ((let ((v (digit-value (integer->char i))))
259                        (or (not v) (and (>= v 0) (<= v 9))))
260                      (loop (+ i 1)))
261                     (else #f))))
262
263
264;; Confirm predicate compliance to R7RS.
265
266(test-assert (char-upper-case? (integer->char #x2160)))   ; ROMAN NUMERAL ONE
267(test-assert (char-upper-case? (integer->char #x24B6)))   ; CIRCLED CAPITAL A
268(test-assert (char-lower-case? (integer->char #x2170)))   ; SMALL ROMAN NUMERAL ONE
269(test-assert (char-lower-case? (integer->char #x24D0)))   ; CIRCLED SMALL A
270(test-assert (char-lower-case? (integer->char #x02B0)))   ; MODIFIER SMALL H
271(test-assert (char-alphabetic? (integer->char #x0345)))   ; COMBINING YPOGEGRAMMENI
272(test-assert (char-alphabetic? (integer->char #x093E)))   ; DEVANAGARI VOWEL SIGN AA
273(test-assert (char-alphabetic? (integer->char #x2160)))   ; Nl is Alphabetic
274
275(test-assert (char-whitespace? (integer->char #x0085)))   ; NEL
276(test-assert (char-whitespace? (integer->char #x2029)))   ; PARAGRAPH SEPARATOR
277(test-assert (char-whitespace? (integer->char #x202F)))   ; NARROW NO-BREAK SPACE
278(test-assert (not (char-whitespace? (integer->char #x001C))))
279(test-assert (not (char-whitespace? (integer->char #x001F))))
280(test-assert (not (char-whitespace? (integer->char #x180E))))
281
282;; Confirm title case folding.
283
284(test-equal #\x01C4 (char-upcase (integer->char #x01C5)))   ; LATIN CAPITAL DZ
285(test-equal #\x01C6 (char-downcase (integer->char #x01C5))) ; latin small dz
286
287;; As per R7RS 7.1.1
288;;
289;; <intraline whitespace> -> <space or tab>
290;; <line ending> -> <newline> | <return> <newline> | <return>.
291;; <whitespace> -> <intraline whitespace> | <line ending>
292
293(test-equal (list (string->symbol "1\x1c;2"))
294            (with-input-from-string "(1\x1c;2)" read))
295(test-equal '(1 2) (with-input-from-string "(1 2)" read))
296(test-equal '(1 2) (with-input-from-string "(1\n2)" read))
297
298(test-end)
299
300(test-exit)