unicode.lisp 18.1 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
;;; -*- Log: code.log; Package: Unicode -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
  "$Header: src/code/unicode.lisp $")
;;;
;;; **********************************************************************
;;;
;;; Functions to process Unicode strings for CMU Common Lisp
;;; Written by Paul Foley and Raymond Toy.
;;;
;;; ****************************************************************
;;;
(in-package "UNICODE")
(intl:textdomain "cmucl")

;; An example where this differs from cl:string-upcase differ:
;; #\Latin_Small_Letter_Sharp_S
(defun string-upcase-full (string &key (start 0) end)
  _N"Given a string, returns a new string that is a copy of it with
  all lower case alphabetic characters converted to uppercase using
  full case conversion."
  (declare (fixnum start)) (let* ((string (if
  (stringp string) string (string string)))
	 (slen (length string)))
    (declare (fixnum slen))
    (with-output-to-string (s)
      (lisp::with-one-string string start end offset
        (let ((offset-slen (+ slen offset)))
	  (declare (fixnum offset-slen))
	  (write-string string s :start offset :end start)
	  (do ((index start (1+ index)))
	      ((= index (the fixnum end)))
	    (declare (fixnum index))
	    (multiple-value-bind (code wide)
39
		(codepoint string index)
40
41
42
43
44
45
	      (when wide (incf index))
	      ;; Handle ASCII specially because this is called early in
	      ;; initialization, before unidata is available.
	      (cond ((< 96 code 123)
		     (write-char (code-char (decf code 32)) s))
		    ((> code 127)
46
		     (write-string (unicode-full-case-upper code) s))
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
		    (t
		     (multiple-value-bind (hi lo)
			 (surrogates code)
		       (write-char hi s)
		       (when lo
			 (write-char lo s)))))))
	  (write-string string s :start end :end offset-slen))))))

(defun string-upcase (string &key (start 0) end (casing :full))
  _N"Given a string, returns a new string that is a copy of it with
  all lower case alphabetic characters converted to uppercase.  Casing
  is :simple or :full for simple or full case conversion,
  respectively."
  (declare (fixnum start))
  (if (eq casing :simple)
      (cl:string-upcase string :start start :end end)
      (string-upcase-full string :start start :end end)))


;; An example this differs from cl:string-downcase:
;; #\Latin_Capital_Letter_I_With_Dot_Above.
(defun string-downcase-full (string &key (start 0) end)
  _N"Given a string, returns a new string that is a copy of it with
  all uppercase alphabetic characters converted to lowercase using
  full case conversion.."
  (declare (fixnum start))
  (let* ((string (if (stringp string) string (string string)))
	 (slen (length string)))
    (declare (fixnum slen))
    (with-output-to-string (s)
      (lisp::with-one-string string start end offset
        (let ((offset-slen (+ slen offset)))
	  (declare (fixnum offset-slen))
	  (write-string string s :start offset :end start)
	  (do ((index start (1+ index)))
	      ((= index (the fixnum end)))
	    (declare (fixnum index))
	    (multiple-value-bind (code wide)
85
		(codepoint string index)
86
87
88
89
90
91
	      (when wide (incf index))
	      ;; Handle ASCII specially because this is called early in
	      ;; initialization, before unidata is available.
	      (cond ((< 64 code 91)
		     (write-char (code-char (incf code 32)) s))
		    ((> code 127)
92
		     (write-string (unicode-full-case-lower code) s))
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
		    (t
		     ;; Handle codes below 64
		     (multiple-value-bind (hi lo)
			 (surrogates code)
		       (write-char hi s)
		       (when lo
			 (write-char lo s)))))))
	  (write-string string s :start end :end offset-slen))))))

(defun string-downcase (string &key (start 0) end (casing :full))
  _N"Given a string, returns a new string that is a copy of it with all
  uppercase alphabetic characters converted to lowercase.  Casing is
  :simple or :full for simple or full case conversion, respectively."

  (declare (fixnum start))
  (if (eq casing :simple)
      (cl:string-downcase string :start start :end end)
      (string-downcase-full string :start start :end end)))


;;;
;;; This is a Lisp translation of the Scheme code from William
;;; D. Clinger that implements the word-breaking algorithm.  This is
;;; used with permission.
;;;
;;; This version is modified from the original at
;;; http://www.ccs.neu.edu/home/will/R6RS/ to conform to CMUCL's
;;; implementation of the word break properties.
;;;
;;;
;;; Copyright statement and original comments:
;;;
;;;--------------------------------------------------------------------------------

;; Copyright 2006 William D Clinger.
;;
;; Permission to copy this software, in whole or in part, to use this
;; software for any lawful purpose, and to redistribute this software
;; is granted subject to the restriction that all copies made of this
;; software must include this copyright and permission notice in full.
;;
;; I also request that you send me a copy of any improvements that you
;; make to this software so that they may be incorporated within it to
;; the benefit of the Scheme community.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Word-breaking as defined by Unicode Standard Annex #29.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Implementation notes.
;;
;; The string-foldcase, string-downcase, and string-titlecase
;; procedures rely on the notion of a word, which is defined
;; by Unicode Standard Annex 29.
;;
;; The string-foldcase and string-downcase procedures rely on
;; word boundaries only when they encounter a Greek sigma, so
;; their performance should not be greatly affected by the
;; performance of the word-breaking algorithm.
;;
;; The string-titlecase procedure must find all word boundaries,
;; but it is typically used on short strings (titles).
;;
;; Hence the performance of the word-breaking algorithm should
;; not matter too much for this reference implementation.
;; Word-breaking is more generally useful, however, so I tried
;; to make this implementation reasonably efficient.
;;
;; Word boundaries are defined by 14 different rules in
;; Unicode Standard Annex #29, and by GraphemeBreakProperty.txt
;; and WordBreakProperty.txt.  See also WordBreakTest.html.
;;
;; My original implementation of those specifications failed
;; 6 of the 494 tests in auxiliary/WordBreakTest.txt, but it
;; appeared to me that those tests were inconsistent with the
;; word-breaking rules in UAX #29.  John Cowan forwarded my
;; bug report to the Unicode experts, and Mark Davis responded
;; on 29 May 2007:
;;
;;   Thanks for following up on this. I think you have found a problem in the
;;   formulation of word break, not the test. The intention was to break after a
;;   Sep character, as is done in Sentence break. So my previous suggestion was
;;   incorrect; instead, what we need is a new rule:
;; 
;;   *Break after paragraph separators.*
;;    WB3a. Sep �
;;   I'll make a propose to the UTC for this.
;;
;; Here is Will's translation of those rules (including WB3a)
;; into a finite state machine that searches forward within a
;; string, looking for the next position at which a word break
;; is allowed.  The current state consists of an index i into
;; the string and a summary of the left context whose rightmost
;; character is at index i.  The left context is usually
;; determined by the character at index i, but there are three
;; complications:
;;
;;     Extend and Format characters are ignored unless they
;;         follow a separator or the beginning of the text.
;;     ALetter followed by MidLetter is treated specially.
;;     Numeric followed by MidNum is treated specially.
;;
;; In the implementation below, the left context ending at i
;; is encoded by the following symbols:
;;
;;     CR
;;     Sep (excluding CR)
;;     ALetter
;;     MidLetter
;;     ALetterMidLetter (ALetter followed by MidLetter)
;;     Numeric
;;     MidNum
;;     NumericMidNum (Numeric followed by MidNum)
;;     Katakana
;;     ExtendNumLet
;;     other (none of the above)
;;
;; Given a string s and an exact integer i (which need not be
;; a valid index into s), returns the index of the next character
;; that is not part of the word containing the character at i,
;; or the length of s if the word containing the character at i
;; extends through the end of s.  If i is negative or a valid
;; index into s, then the returned value will be greater than i.
;;
;;;--------------------------------------------------------------------------------

(defun string-next-word-break (s i)
  _N"Given a string, S, and a starting index, return the index of the
  next character that is not part of the word containing the character
  at the index, or the length of S if the word containing the
  character extends to the end of S.  If the index is negative or
  valid index into S, the returned value will be strictly greater than
  the index."
  (let ((n (length s)))
    (labels
	((char-word-break-category (c)
	   ;; Map our unicode word break property into what this
	   ;; algorithm wants.
233
	   (let ((cat (unicode-word-break c)))
234
235
236
237
238
239
240
241
242
243
	     (case cat
	       ((:lf :cr :newline)
		:sep)
	       ((:extend :format)
		:extend-or-format)
	       (otherwise cat))))
	 (left-context (i)
	   ;; Given a valid index i into s, returns the left context
	   ;; at i.
	   (multiple-value-bind (c widep)
244
	       (codepoint s i n)
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
	     (let* ((back
		     ;; If we're at a regular character or a leading
		     ;; surrogate, decrementing by 1 gets us the to
		     ;; previous character.  But for a trailing
		     ;; surrogate, we need to decrement by 2!
		     (if (eql widep -1)
			 2
			 1))
		    (cat (char-word-break-category c)))
	       (case cat
		 ((:sep)
		  (if (= c (char-code #\return)) :cr cat))
		 ((:midletter :midnumlet)
		  (let ((i-1 (- i back)))
		    (if (and (<= 0 i-1)
			     (eq (left-context i-1) :aletter))
			:aletter-midletter
			cat)))
		 ((:midnum :midnumlet)
		  (let ((i-1 (- i back)))
		    (if (and (<= 0 i-1)
			     (eq (left-context i-1) :numeric))
			:numeric-midnum
			cat)))
		 ((:extendorformat)
		  (if (< 0 i)
		      (left-context (- i back))
		      :other))
		 (otherwise cat)))))

	 (index-of-previous-non-ignored (j)
	   ;; Returns the index of the last non-Extend, non-Format
	   ;; character within (substring s 0 j).  Should not be
	   ;; called unless such a character exists.

	   (let* ((j1 (- j 1)))
	     (multiple-value-bind (c widep)
282
		 (codepoint s j1)
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
	       (when (eql widep -1)
		 ;; Back up one more if we're at the trailing
		 ;; surrogate.
		 (decf j1))
	       (let ((cat (char-word-break-category c)))
		 (case cat
		   ((:extend-or-format)
		    (index-of-previous-non-ignored j1))
		   (otherwise j1))))))

	 (lookup (j context)
	   ;; Given j and the context to the left of (not including) j,
	   ;; returns the index at the start of the next word
	   ;; (or before which a word break is permitted).

	   (if (>= j n)
	       (case context
		 ((:aletter-midletter :numeric-midnum)
		  (let ((j (index-of-previous-non-ignored n)))
		    (if (< i j) j n)))
		 (otherwise n))
	       (multiple-value-bind (c widep)
305
		   (codepoint s j)
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
		 (let* ((next-j
			 ;; The next character is either 1 or 2 code
			 ;; units away.  For a leading surrogate, it's
			 ;; 2; Otherwise just 1.
			 (if (eql widep 1)
			     2
			     1))
			(cat (char-word-break-category c)))
		   (case cat
		     ((:extend-or-format)
		      (case context
			((:cr :sep) j)
			(otherwise (lookup (+ j next-j) context))))
		     (otherwise
		      (case context
			((:cr)
			 (if (= c (char-code #\linefeed))
			     ;; Rule WB3:  Don't break CRLF, continue looking
			     (lookup (+ j next-j) cat)
			     j))
			((:aletter)
			 (case cat
			   ((:aletter :numeric :extendnumlet)
			    ;; Rules WB5, WB9, ?
			    (lookup (+ j next-j) cat))
			   ((:midletter :midnumlet)
			    ;; Rule WB6, need to keep looking
			    (lookup (+ j next-j) :aletter-midletter))
			   (otherwise j)))
			((:aletter-midletter)
			 (case cat
			   ((:aletter)
			    ;; Rule WB7
			    (lookup (+ j next-j) cat))
			   (otherwise
			    ;; Rule WB6 and WB7 were extended, but the
			    ;; region didn't end with :aletter.  So
			    ;; backup and break at that point.
			    (let ((j2 (index-of-previous-non-ignored j)))
			      (if (< i j2) j2 j)))))
			((:numeric)
			 (case cat
			   ((:numeric :aletter :extendnumlet)
			    ;; Rules WB8, WB10, ?
			    (lookup (+ j next-j) cat))
			   ((:midnum :midnumlet)
			    ;; Rules WB11, need to keep looking
			    (lookup (+ j next-j) :numeric-midnum))
			   (otherwise j)))
			((:numeric-midnum)
			 (case cat
			   ((:numeric)
			    ;; Rule WB11, keep looking
			    (lookup (+ j next-j) cat))
			   (otherwise
			    ;; Rule WB11, WB12 were extended, but the
			    ;; region didn't end with :numeric, so
			    ;; backup and break at that point.
			    (let ((j2 (index-of-previous-non-ignored j)))
			      (if (< i j2) j2 j)))))
			((:midletter :midnum :midnumlet)
			 ;; Rule WB14
			 j)
			((:katakana)
			 (case cat
			   ((:katakana :extendnumlet)
			    ;; Rule WB13, WB13a
			    (lookup (+ j next-j) cat))
			   (otherwise j)))
			((:extendnumlet)
			 (case cat
			   ((:extendnumlet :aletter :numeric :katakana)
			    ;; Rule WB13a, WB13b
			    (lookup (+ j next-j) cat))
			   (otherwise j)))
			((:regional_indicator)
			 (case cat
			   ((:regional_indicator)
			    ;; Rule WB13c
			    (lookup (+ j next-j) cat))
			   (otherwise j)))
			(otherwise j)))))))))
      (declare (notinline lookup left-context))
      (cond ((< i 0)
	     ;; Rule WB1
	     0)
	    ((<= n i)
	     ;; Rule WB2
	     n)
	    (t
	     (multiple-value-bind (c widep)
397
		 (codepoint s i)
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
	       (declare (ignore c))
	       (lookup (+ i (if (eql widep 1) 2 1)) (left-context i))))))))

(defun string-capitalize-unicode (string &key (start 0) end (casing :simple))
  "Capitalize String using the Unicode word-break algorithm to find
  the words in String.  The beginning is capitalized depending on the
  value of Casing"
  (declare (type (member :simple :full :title) casing))
  (let* ((string (if (stringp string) string (string string)))
	 (slen (length string)))
    (declare (fixnum slen))
    (with-output-to-string (result)
      (lisp::with-one-string string start end offset
        (let ((offset-slen (+ slen offset)))
	  (declare (fixnum offset-slen))

	  (write-string string result :start 0 :end start)
	  (let ((upper (ecase casing
			 (:simple
			  #'(lambda (ch)
			      (multiple-value-bind (hi lo)
419
				  (surrogates (unicode-upper ch))
420
421
422
423
				(write-char hi result)
				(when lo (write-char lo result)))))
			 (:full
			  #'(lambda (ch)
424
			      (write-string (unicode-full-case-upper ch) result)))
425
426
			 (:title
			  #'(lambda (ch)
427
			      (write-string (unicode-full-case-title ch) result))))))
428
429
430
431
432
433
434
	    (do ((start start next)
		 (next (string-next-word-break string start)
		       (string-next-word-break string next)))
		((or (= start next)
		     (>= start end)))
	      ;; Convert the first character of the word to upper
	      ;; case, and then make the rest of the word lowercase.
435
	      (funcall upper (codepoint string start))
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
	      (write-string (string-downcase string :start (1+ start)
						    :end next
						    :casing casing)
			    result
			    :start (1+ start)
			    :end next)))
	  (write-string string result :start end :end offset-slen))))))

(defun string-capitalize-full (string &key (start 0) end (casing :full))
  "Capitalize String using the Common Lisp word-break algorithm to find
  the words in String.  The beginning is capitalized depending on the
  value of Casing"
  (declare (fixnum start)
	   (type (member :simple :full :title) casing))
  (let* ((string (if (stringp string) string (string string)))
	 (slen (length string)))
    (declare (fixnum slen))
    (with-output-to-string (s)
      (lisp::with-one-string string start end offset
        (let ((offset-slen (+ slen offset)))
	  (declare (fixnum offset-slen))
	  (write-string string s :start offset :end start)
	  (flet ((alphanump (m)
		   (or (< 47 m 58) (< 64 m 91) (< 96 m 123)
		       #+(and unicode (not unicode-bootstrap))
		       (and (> m 127)
462
463
464
			    (<= +unicode-category-letter+
				(unicode-category m)
				(+ +unicode-category-letter+ #x0F)))))
465
466
467
468
469
		 (upper (ch)
		   (ecase casing
		     (:simple
		      #'(lambda (ch)
			  (multiple-value-bind (hi lo)
470
			      (surrogates (unicode-upper ch))
471
472
473
474
			    (write-char hi s)
			    (when lo (write-char lo s)))))
		     (:full
		      #'(lambda (ch)
475
			  (write-string (unicode-full-case-upper ch) s)))
476
477
		     (:title
		      #'(lambda (ch)
478
			  (write-string (unicode-full-case-title ch) s))))))
479
480
481
482
483
	    (do ((index start (1+ index))
		 (newword t))
		((= index (the fixnum end)))
	      (declare (fixnum index))
	      (multiple-value-bind (code wide)
484
		  (codepoint string index)
485
486
487
488
489
490
491
492
493
494
495
496
497
		(when wide (incf index))
		(cond ((not (alphanump code))
		       (multiple-value-bind (hi lo)
			   (surrogates code)
			 (write-char hi s)
			 (when lo (write-char lo s)))
		       (setq newword t))
		      (newword
		       ;; Char is first case-modifiable after non-case-modifiable
		       (funcall upper code)
		       (setq newword ()))
		      (t
		       ;; char is case-modifiable, but not first
498
		       (write-string (unicode-full-case-lower code) s))))))
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
	  (write-string string s :start end :end offset-slen))))))

(defun string-capitalize (string &key (start 0) end
				 (casing :title)
				 (unicode-word-break t))
  _N"Given a string, returns a copy of the string with the first
  character of each ``word'' converted to upper-case, and remaining
  chars in the word converted to lower case. Casing is :simple, :full
  or :title for simple, full or title case conversion, respectively.  If
  Unicode-Word-Break is non-Nil, then the Unicode word-breaking
  algorithm is used to determine the word boundaries.  Otherwise, A
  ``word'' is defined to be a string of case-modifiable characters
  delimited by non-case-modifiable chars.  "

  (declare (fixnum start)
	   (type (member :simple :full :title) casing))
  (if unicode-word-break
      (string-capitalize-unicode string :start start :end end :casing casing)
      (if (eq casing :simple)
	  (cl:string-capitalize string :start start :end end)
	  (string-capitalize-full string :start start :end end :casing casing))))