source: project/release/5/utf8/trunk/utf8-case-map.scm @ 36058

Last change on this file since 36058 was 36058, checked in by Kooda, 3 years ago

Port the utf8 egg to CHICKEN 5

File size: 11.0 KB
Line 
1;;;; utf8-case-map.scm -- Unicode locale-aware case-mappings
2;;
3;; Copyright (c) 2004-2010 Alex Shinn. All rights reserved.
4;; BSD-style license: http://synthcode.com/license.txt
5
6;; Usage:
7;;
8;;   (utf8-string-upcase str-or-port [locale])
9;;   (utf8-string-downcase str-or-port [locale])
10;;   (utf8-string-titlecase str-or-port [locale])
11
12;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
13
14(declare
15  (no-bound-checks)
16  (no-procedure-checks) )
17
18(module
19 utf8-case-map
20 (
21  char-upcase-single char-downcase-single char-titlecase-single
22  char-downcase* char-upcase* char-titlecase*
23  utf8-string-upcase utf8-string-downcase utf8-string-titlecase)
24
25(import scheme
26        (chicken base)
27        (chicken bitwise)
28        (chicken condition)
29        (chicken file)
30        (chicken file posix)
31        (chicken io)
32        (chicken platform)
33        (chicken port)
34        srfi-4
35        utf8-lolevel (except utf8-srfi-14 char-set:hex-digit) unicode-char-sets)
36
37;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
38
39(define *data-file-path*
40  (list "./data" (chicken-home)))
41
42(define (find-data-file name)
43  (let lp ((ls *data-file-path*))
44    (and (pair? ls)
45         (let ((path (string-append (car ls) "/" name)))
46           (if (file-exists? path)
47             path
48             (lp (cdr ls)))))))
49
50(define char->ucs char->integer)
51(define ucs->char integer->char)
52
53(define read-binary-uint32-le
54  ;; files distributed as little-endian in egg
55  (lambda (port)
56    (let* ((b1 (read-byte port)) (b2 (read-byte port))
57           (b3 (read-byte port)) (b4 (read-byte port)))
58      (if (eof-object? b4)
59          b4
60          (bitwise-ior
61           b1
62           (arithmetic-shift b2 8)
63           (arithmetic-shift b3 16)
64           (arithmetic-shift b4 24))))))
65
66(define read-binary-uint16-le
67  ;; files distributed as little-endian in egg
68  (lambda (port)
69    (let* ((b1 (read-byte port)) (b2 (read-byte port)))
70      (if (eof-object? b2)
71          b2
72          (bitwise-ior b1 (arithmetic-shift b2 8))))))
73
74;; currently only defined for u16 and u32 vectors
75(define (read-block! vec port)
76  (cond
77    ((u16vector? vec)
78     (let ((len (u16vector-length vec)))
79       (do ((i 0 (+ i 1)))
80           ((= i len))
81         (u16vector-set! vec i (read-binary-uint16-le port)))))
82    ((u32vector? vec)
83     (let ((len (u32vector-length vec)))
84       (do ((i 0 (+ i 1)))
85           ((= i len))
86         (u32vector-set! vec i (read-binary-uint32-le port)))))
87    (else
88     (error 'read-block! "unsupported type" vec))))
89
90(define (with-string-io* s thunk)
91  (with-output-to-string
92    (lambda ()
93      (with-input-from-port (if (string? s) (open-input-string s) s)
94        thunk))))
95
96(define (display-utf8 x)
97  (if (char? x)
98      (write-utf8-char x)
99      (display x)))
100
101;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
102;; simple case conversions
103
104(define *char-case-file-1* "case-map-1.dat")
105
106(define *char-case-table-1*
107  (or (condition-case
108          (and-let* ((file (find-data-file *char-case-file-1*))
109                     (size (file-size file))
110                     (vec (make-u32vector (quotient size 4))))
111            (call-with-input-file file
112              (cut read-block! vec <>) #:binary)
113            vec)
114        (var () #f))
115      (begin
116        (warning "couldn't load case-map-1.dat")
117        (make-u32vector 0))))
118
119(define *char-case-count-1*
120  (- (quotient (u32vector-length *char-case-table-1*) 4) 1))
121
122(define (char-case-index tab i)
123  (if (zero? (u32vector-length tab))
124    0
125    (do ((j 0 (+ j 4)))
126        ((>= (u32vector-ref tab j) i) (quotient j 4)))))
127
128(define (char-case-search tab i off . opt)
129  (let-optionals* opt ((lo 0) (hi *char-case-count-1*))
130    (and
131     (>= hi lo)
132     (cond
133       ((= i (u32vector-ref tab (* lo 4)))
134        (u32vector-ref tab (+ (* lo 4) off)))
135       ((= i (u32vector-ref tab (* hi 4)))
136        (u32vector-ref tab (+ (* hi 4) off)))
137       (else
138        (let loop ((a lo) (b hi))
139          (if (= a b)
140            #f
141            (let* ((mid (+ a (quotient (- b a) 2)))
142                   (ind (* mid 4))
143                   (val (u32vector-ref tab ind)))
144              (cond ((< i val) (if (= mid b) #f (loop a mid)))
145                    ((> i val) (if (= mid a) #f (loop mid b)))
146                    (else (u32vector-ref tab (+ ind off))))))))))))
147
148;; just inline these two indexes for speed
149(define *index-2500* (char-case-index *char-case-table-1* #x2500))
150(define *index-FF20* (char-case-index *char-case-table-1* #xFF20))
151
152(define (char-map-single-case i off)
153  (cond ((< i 128) #f)
154        ((< i #x2500)
155         (and-let* ((j (char-case-search *char-case-table-1*
156                                         i off 0 *index-2500*)))
157           (ucs->char j)))
158        ((> i #xFF20)
159         (and-let* ((j (char-case-search *char-case-table-1*
160                                         i off *index-FF20*
161                                         *char-case-count-1*)))
162           (ucs->char j)))
163        (else #f)))
164
165;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
166;; special casing
167
168(define *char-case-file-2* "case-map-2.dat")
169
170(define *char-case-table-2*
171  (or (and-let* ((file (find-data-file *char-case-file-2*)))
172        (condition-case
173            (with-input-from-file file read)
174          (var () #f)))
175      (begin
176        (warning "couldn't load case-map-2.dat")
177        '#())))
178
179(define *char-case-length-2* (vector-length *char-case-table-2*))
180
181(define (char-map-multi-case i off)
182  (let loop ((a 0) (b *char-case-length-2*))
183    (if (= a b)
184      #f
185      (let* ((mid (+ a (quotient (- b a) 2)))
186             (vec (vector-ref *char-case-table-2* mid))
187             (val (vector-ref vec 0)))
188        (cond ((< i val) (if (= mid b) #f (loop a mid)))
189              ((> i val) (if (= mid a) #f (loop mid b)))
190              (else (vector-ref vec off)))))))
191
192;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
193;; interface
194
195;; returns a single char
196(define (char-upcase-single c)
197  (let ((i (char->ucs c)))
198    (if (< i 128)
199      (char-upcase c)
200      (or (char-map-single-case i 1) c))))
201(define (char-downcase-single c)
202  (let ((i (char->ucs c)))
203    (if (< i 128)
204      (char-downcase c)
205      (or (char-map-single-case i 2) c))))
206(define (char-titlecase-single c)
207  (let ((i (char->ucs c)))
208    (if (< i 128)
209      (char-upcase c)
210      (or (char-map-single-case i 3) c))))
211
212;; may return a char or string
213(define (char-downcase* c)
214  (or (char-map-multi-case (char->ucs c) 1)
215      (char-downcase-single c)))
216(define (char-titlecase* c)
217  (or (char-map-multi-case (char->ucs c) 2)
218      (char-titlecase-single c)))
219(define (char-upcase* c)
220  (or (char-map-multi-case (char->ucs c) 3)
221      (char-upcase-single c)))
222
223(define (lang? opt . args)
224  (and (pair? opt)
225       (let ((lang (car opt)))
226         (and (>= (string-length lang) 2)
227              (let lp ((ls args))
228                (and (pair? ls)
229                     (or (let ((lang2 (car ls)))
230                           (and (eqv? (string-ref lang 0)
231                                      (string-ref lang2 0))
232                                (eqv? (string-ref lang 1)
233                                      (string-ref lang2 1))))
234                         (lp (cdr ls)))))))))
235
236(define grave-accent (char->utf8-string (ucs->char #x0300)))
237(define acute-accent (char->utf8-string (ucs->char #x0301)))
238(define tilde-accent (char->utf8-string (ucs->char #x0303)))
239(define dot-above (char->utf8-string (ucs->char #x0307)))
240(define dotted-capital-i (ucs->char #x0130))
241(define dotless-small-i (ucs->char #x0131))
242(define dotted-small-i (string-append "i" dot-above))
243(define dotted-small-i/grave
244  (string-append "i" dot-above grave-accent))
245(define dotted-small-i/acute
246  (string-append "i" dot-above acute-accent))
247(define dotted-small-i/tilde
248  (string-append "i" dot-above tilde-accent))
249(define small-final-sigma
250  (ucs->char #x03C2))
251(define small-sigma
252  (ucs->char #x03C3))
253
254;; takes an optional locale string
255(define (utf8-string-upcase str . opt)
256  (with-string-io* str
257    (lambda ()
258      (if (lang? opt "tr" "az")
259        (let loop ((c (read-utf8-char)))
260          (unless (eof-object? c)
261            (display-utf8
262             (if (eqv? c #\i) dotted-capital-i (char-upcase* c)))
263            (loop (read-utf8-char))))
264        (let loop ((c (read-utf8-char)))
265          (unless (eof-object? c)
266            (display-utf8 (char-upcase* c))
267            (loop (read-utf8-char))))))))
268
269(define (char-downcase-locale c next opt)
270  (or
271   (case (char->ucs c)
272     ;; Final Sigma
273     ((#x03A3) (if (and (char? next)
274                        (char-set-contains? char-set:greek next))
275                 small-sigma
276                 small-final-sigma))
277     ;; Lithuanian (XXXX add More_Above logic)
278     ((#x00CC) (and (lang? opt "lt") dotted-small-i/grave))
279     ((#x00CD) (and (lang? opt "lt") dotted-small-i/acute))
280     ((#x0128) (and (lang? opt "lt") dotted-small-i/tilde))
281     ;; Turkish and Azeri
282     ((#x0130) (if (lang? opt "tr" "az") #\i dotted-small-i))
283     ((#x0307) (and (lang? opt "tr" "az") ""))
284     ((#x0049) (and (lang? opt "tr" "az") dotless-small-i))
285     (else #f))
286   (char-downcase* c)))
287
288(define (utf8-string-downcase str . opt)
289  (with-string-io* str
290    (lambda ()
291      (let loop ((c (read-utf8-char)))
292        (unless (eof-object? c)
293          (let ((next (read-utf8-char)))
294            (display-utf8 (char-downcase-locale c next opt))
295            (loop next)))))))
296
297;; Note: there are some characters which define case mappings (such as
298;; the circled latin letters), but which unicode doesn't consider
299;; alphabetic.  So the faster and more natural test for the alphabetic
300;; property doesn't work, and we somewhat clumsily test whether or not
301;; the characters are either upper or lowercase.
302;;
303;; An alternative approach is to explicitly compare the script property
304;; of successive characters and start a new word when that property
305;; changes.  So a consecutive string of Greek letters followed
306;; immediately by Latin characters would result in the first Greek
307;; letter and first Latin character being uppercased, as opposed to just
308;; the first Greek letter as we do now.
309(define (has-case? c)
310  ;;(char-set-contains? char-set:alphabetic c)
311  (or (char-set-contains? char-set:uppercase c)
312      (char-set-contains? char-set:lowercase c)))
313
314(define (utf8-string-titlecase str . opt)
315  (with-string-io* str
316    (lambda ()
317      (letrec
318          ((in-word
319            (lambda (c)
320              (unless (eof-object? c)
321                (let ((next (read-utf8-char)))
322                  (display-utf8 (char-downcase-locale c next opt))
323                  (if (has-case? c)
324                    (in-word next)
325                    (out-word next))))))
326           (out-word
327            (lambda (c)
328              (unless (eof-object? c)
329                (let ((next (read-utf8-char)))
330                  (cond
331                    ((has-case? c)
332                     (display-utf8
333                      (if (eqv? c #\i)
334                        (if (lang? opt "tr" "az") dotted-capital-i #\I)
335                        (char-titlecase* c)))
336                     (in-word next))
337                    (else
338                     (display-utf8 c)
339                     (out-word next))))))))
340        (out-word (read-utf8-char))))))
341
342)
Note: See TracBrowser for help on using the repository browser.