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

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

utf8 egg: embed case mapping data into binaries

File size: 9.1 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 char->ucs char->integer)
40(define ucs->char integer->char)
41
42(define (with-string-io* s thunk)
43  (with-output-to-string
44    (lambda ()
45      (with-input-from-port (if (string? s) (open-input-string s) s)
46        thunk))))
47
48(define (display-utf8 x)
49  (if (char? x)
50      (write-utf8-char x)
51      (display x)))
52
53;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
54;; simple case conversions
55
56(define *char-case-table-1* (include "case-map-1.dat"))
57
58(define *char-case-count-1*
59  (- (quotient (u32vector-length *char-case-table-1*) 4) 1))
60
61(define (char-case-index tab i)
62  (if (zero? (u32vector-length tab))
63    0
64    (do ((j 0 (+ j 4)))
65        ((>= (u32vector-ref tab j) i) (quotient j 4)))))
66
67(define (char-case-search tab i off . opt)
68  (let-optionals* opt ((lo 0) (hi *char-case-count-1*))
69    (and
70     (>= hi lo)
71     (cond
72       ((= i (u32vector-ref tab (* lo 4)))
73        (u32vector-ref tab (+ (* lo 4) off)))
74       ((= i (u32vector-ref tab (* hi 4)))
75        (u32vector-ref tab (+ (* hi 4) off)))
76       (else
77        (let loop ((a lo) (b hi))
78          (if (= a b)
79            #f
80            (let* ((mid (+ a (quotient (- b a) 2)))
81                   (ind (* mid 4))
82                   (val (u32vector-ref tab ind)))
83              (cond ((< i val) (if (= mid b) #f (loop a mid)))
84                    ((> i val) (if (= mid a) #f (loop mid b)))
85                    (else (u32vector-ref tab (+ ind off))))))))))))
86
87;; just inline these two indexes for speed
88(define *index-2500* (char-case-index *char-case-table-1* #x2500))
89(define *index-FF20* (char-case-index *char-case-table-1* #xFF20))
90
91(define (char-map-single-case i off)
92  (cond ((< i 128) #f)
93        ((< i #x2500)
94         (and-let* ((j (char-case-search *char-case-table-1*
95                                         i off 0 *index-2500*)))
96           (ucs->char j)))
97        ((> i #xFF20)
98         (and-let* ((j (char-case-search *char-case-table-1*
99                                         i off *index-FF20*
100                                         *char-case-count-1*)))
101           (ucs->char j)))
102        (else #f)))
103
104;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
105;; special casing
106
107(define *char-case-table-2* (include "case-map-2.dat"))
108(define *char-case-length-2* (vector-length *char-case-table-2*))
109
110(define (char-map-multi-case i off)
111  (let loop ((a 0) (b *char-case-length-2*))
112    (if (= a b)
113      #f
114      (let* ((mid (+ a (quotient (- b a) 2)))
115             (vec (vector-ref *char-case-table-2* mid))
116             (val (vector-ref vec 0)))
117        (cond ((< i val) (if (= mid b) #f (loop a mid)))
118              ((> i val) (if (= mid a) #f (loop mid b)))
119              (else (vector-ref vec off)))))))
120
121;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
122;; interface
123
124;; returns a single char
125(define (char-upcase-single c)
126  (let ((i (char->ucs c)))
127    (if (< i 128)
128      (char-upcase c)
129      (or (char-map-single-case i 1) c))))
130(define (char-downcase-single c)
131  (let ((i (char->ucs c)))
132    (if (< i 128)
133      (char-downcase c)
134      (or (char-map-single-case i 2) c))))
135(define (char-titlecase-single c)
136  (let ((i (char->ucs c)))
137    (if (< i 128)
138      (char-upcase c)
139      (or (char-map-single-case i 3) c))))
140
141;; may return a char or string
142(define (char-downcase* c)
143  (or (char-map-multi-case (char->ucs c) 1)
144      (char-downcase-single c)))
145(define (char-titlecase* c)
146  (or (char-map-multi-case (char->ucs c) 2)
147      (char-titlecase-single c)))
148(define (char-upcase* c)
149  (or (char-map-multi-case (char->ucs c) 3)
150      (char-upcase-single c)))
151
152(define (lang? opt . args)
153  (and (pair? opt)
154       (let ((lang (car opt)))
155         (and (>= (string-length lang) 2)
156              (let lp ((ls args))
157                (and (pair? ls)
158                     (or (let ((lang2 (car ls)))
159                           (and (eqv? (string-ref lang 0)
160                                      (string-ref lang2 0))
161                                (eqv? (string-ref lang 1)
162                                      (string-ref lang2 1))))
163                         (lp (cdr ls)))))))))
164
165(define grave-accent (char->utf8-string (ucs->char #x0300)))
166(define acute-accent (char->utf8-string (ucs->char #x0301)))
167(define tilde-accent (char->utf8-string (ucs->char #x0303)))
168(define dot-above (char->utf8-string (ucs->char #x0307)))
169(define dotted-capital-i (ucs->char #x0130))
170(define dotless-small-i (ucs->char #x0131))
171(define dotted-small-i (string-append "i" dot-above))
172(define dotted-small-i/grave
173  (string-append "i" dot-above grave-accent))
174(define dotted-small-i/acute
175  (string-append "i" dot-above acute-accent))
176(define dotted-small-i/tilde
177  (string-append "i" dot-above tilde-accent))
178(define small-final-sigma
179  (ucs->char #x03C2))
180(define small-sigma
181  (ucs->char #x03C3))
182
183;; takes an optional locale string
184(define (utf8-string-upcase str . opt)
185  (with-string-io* str
186    (lambda ()
187      (if (lang? opt "tr" "az")
188        (let loop ((c (read-utf8-char)))
189          (unless (eof-object? c)
190            (display-utf8
191             (if (eqv? c #\i) dotted-capital-i (char-upcase* c)))
192            (loop (read-utf8-char))))
193        (let loop ((c (read-utf8-char)))
194          (unless (eof-object? c)
195            (display-utf8 (char-upcase* c))
196            (loop (read-utf8-char))))))))
197
198(define (char-downcase-locale c next opt)
199  (or
200   (case (char->ucs c)
201     ;; Final Sigma
202     ((#x03A3) (if (and (char? next)
203                        (char-set-contains? char-set:greek next))
204                 small-sigma
205                 small-final-sigma))
206     ;; Lithuanian (XXXX add More_Above logic)
207     ((#x00CC) (and (lang? opt "lt") dotted-small-i/grave))
208     ((#x00CD) (and (lang? opt "lt") dotted-small-i/acute))
209     ((#x0128) (and (lang? opt "lt") dotted-small-i/tilde))
210     ;; Turkish and Azeri
211     ((#x0130) (if (lang? opt "tr" "az") #\i dotted-small-i))
212     ((#x0307) (and (lang? opt "tr" "az") ""))
213     ((#x0049) (and (lang? opt "tr" "az") dotless-small-i))
214     (else #f))
215   (char-downcase* c)))
216
217(define (utf8-string-downcase str . opt)
218  (with-string-io* str
219    (lambda ()
220      (let loop ((c (read-utf8-char)))
221        (unless (eof-object? c)
222          (let ((next (read-utf8-char)))
223            (display-utf8 (char-downcase-locale c next opt))
224            (loop next)))))))
225
226;; Note: there are some characters which define case mappings (such as
227;; the circled latin letters), but which unicode doesn't consider
228;; alphabetic.  So the faster and more natural test for the alphabetic
229;; property doesn't work, and we somewhat clumsily test whether or not
230;; the characters are either upper or lowercase.
231;;
232;; An alternative approach is to explicitly compare the script property
233;; of successive characters and start a new word when that property
234;; changes.  So a consecutive string of Greek letters followed
235;; immediately by Latin characters would result in the first Greek
236;; letter and first Latin character being uppercased, as opposed to just
237;; the first Greek letter as we do now.
238(define (has-case? c)
239  ;;(char-set-contains? char-set:alphabetic c)
240  (or (char-set-contains? char-set:uppercase c)
241      (char-set-contains? char-set:lowercase c)))
242
243(define (utf8-string-titlecase str . opt)
244  (with-string-io* str
245    (lambda ()
246      (letrec
247          ((in-word
248            (lambda (c)
249              (unless (eof-object? c)
250                (let ((next (read-utf8-char)))
251                  (display-utf8 (char-downcase-locale c next opt))
252                  (if (has-case? c)
253                    (in-word next)
254                    (out-word next))))))
255           (out-word
256            (lambda (c)
257              (unless (eof-object? c)
258                (let ((next (read-utf8-char)))
259                  (cond
260                    ((has-case? c)
261                     (display-utf8
262                      (if (eqv? c #\i)
263                        (if (lang? opt "tr" "az") dotted-capital-i #\I)
264                        (char-titlecase* c)))
265                     (in-word next))
266                    (else
267                     (display-utf8 c)
268                     (out-word next))))))))
269        (out-word (read-utf8-char))))))
270
271)
Note: See TracBrowser for help on using the repository browser.