1 ;;; ucs-normalize.el --- Unicode normalization NFC/NFD/NFKD/NFKC
4 ;; Free Software Foundation, Inc.
6 ;; Author: Taichi Kawabata <kawabata.taichi@gmail.com>
7 ;; Keywords: unicode, normalization
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software: you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation, either version 3 of the License, or
14 ;; (at your option) any later version.
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
26 ;; This program has passed the NormalizationTest-5.1.0.txt.
29 ;; http://www.unicode.org/reports/tr15/
30 ;; http://www.unicode.org/review/pr-29.html
34 ;; http://developer.apple.com/technotes/tn/tn1150.html
36 ;; HFS Normalization excludes following area for decomposition.
38 ;; U+02000 .. U+02FFF :: Punctuation, symbols, dingbats, arrows, etc.
39 ;; (Characters in this region will be composed.)
40 ;; U+0F900 .. U+0FAFF :: CJK compatibility Ideographs.
41 ;; U+2F800 .. U+2FFFF :: CJK compatibility Ideographs.
43 ;; HFS-Normalization is useful for normalizing text involving CJK Ideographs.
46 ;;; Implementation Notes on NFC/HFS-NFC.
49 ;; <Stages> Decomposition Composition
54 ;; HFS-NFD: 'hfs-nfd 'hfs-nfd-comp-p
55 ;; HFS-NFC: 'hfs-nfd t
57 ;; Algorithm for Normalization
59 ;; Before normalization, following data will be prepared.
61 ;; 1. quick-check-list
63 ;; `quick-check-list' consists of characters that will be decomposed
64 ;; during normalization. It includes composition-exclusions,
65 ;; singletons, non-starter-decompositions and decomposable
68 ;; `quick-check-regexp' will search the above characters plus
69 ;; combining characters.
71 ;; 2. decomposition-translation
73 ;; `decomposition-translation' is a translation table that will be
74 ;; used to decompose the characters.
77 ;; Normalization Process
79 ;; A. Searching (`ucs-normalize-region')
81 ;; Region is searched for `quick-check-regexp' to find possibly
82 ;; normalizable point.
84 ;; B. Identification of Normalization Block
86 ;; (1) start of the block
87 ;; If the searched character is a starter and not combining
88 ;; with previous character, then the beginning of the block is
89 ;; the searched character. If searched character is combining
90 ;; character, then previous character will be the target
92 ;; (2) end of the block
93 ;; Block ends at non-composable starter character.
95 ;; C. Decomposition (`ucs-normalize-block')
97 ;; The entire block will be decomposed by
98 ;; `decomposition-translation' table.
100 ;; D. Sorting and Composition of Smaller Blocks (`ucs-normalize-block-compose-chars')
102 ;; The block will be split to multiple samller blocks by starter
103 ;; charcters. Each block is sorted, and composed if necessary.
105 ;; E. Composition of Entire Block (`ucs-normalize-compose-chars')
107 ;; Composed blocks are collected and again composed.
111 (defconst ucs-normalize-version "1.1beta2")
113 (eval-when-compile (require 'cl))
117 (defconst ucs-normalize-composition-exclusions
118 '(#x0958 #x0959 #x095A #x095B #x095C #x095D #x095E #x095F
119 #x09DC #x09DD #x09DF #x0A33 #x0A36 #x0A59 #x0A5A #x0A5B
120 #x0A5E #x0B5C #x0B5D #x0F43 #x0F4D #x0F52 #x0F57 #x0F5C
121 #x0F69 #x0F76 #x0F78 #x0F93 #x0F9D #x0FA2 #x0FA7 #x0FAC
122 #x0FB9 #xFB1D #xFB1F #xFB2A #xFB2B #xFB2C #xFB2D #xFB2E
123 #xFB2F #xFB30 #xFB31 #xFB32 #xFB33 #xFB34 #xFB35 #xFB36
124 #xFB38 #xFB39 #xFB3A #xFB3B #xFB3C #xFB3E #xFB40 #xFB41
125 #xFB43 #xFB44 #xFB46 #xFB47 #xFB48 #xFB49 #xFB4A #xFB4B
126 #xFB4C #xFB4D #xFB4E #x2ADC #x1D15E #x1D15F #x1D160 #x1D161
127 #x1D162 #x1D163 #x1D164 #x1D1BB #x1D1BC #x1D1BD #x1D1BE
129 "Composition Exclusion List.
130 This list is taken from
131 http://www.unicode.org/Public/UNIDATA/CompositionExclusions-5.1.0.txt")
133 ;; Unicode ranges that decompositions & combinings are defined.
134 (defvar check-range nil)
135 (setq check-range '((#x00a0 . #x3400) (#xA600 . #xAC00) (#xF900 . #x10fff) (#x1d000 . #x1dfff) (#x2f800 . #x2faff)))
137 ;; Basic normalization functions
140 (get-char-code-property char 'decomposition)))
141 (if (and decomposition (numberp (car decomposition)))
146 (get-char-code-property char 'decomposition)))
147 (if (symbolp (car decomposition)) (cdr decomposition)
150 (defun hfs-nfd (char)
151 (when (or (and (>= char 0) (< char #x2000))
152 (and (>= char #x3000) (< char #xf900))
153 (and (>= char #xfb00) (< char #x2f800))
158 (defun ucs-normalize-hfs-nfd-comp-p (char)
159 (and (>= char #x2000) (< char #x3000)))
161 (defsubst ucs-normalize-ccc (char)
162 (get-char-code-property char 'canonical-combining-class))
165 ;; Data common to all normalizations
169 (defvar combining-chars nil)
170 (setq combining-chars nil)
171 (defvar decomposition-pair-to-composition nil)
172 (setq decomposition-pair-to-composition nil)
173 (defvar non-starter-decompositions nil)
174 (setq non-starter-decompositions nil)
175 (let ((char 0) ccc decomposition)
178 (do ((char (car start-end) (+ char 1))) ((> char (cdr start-end)))
179 (setq ccc (ucs-normalize-ccc char))
180 (setq decomposition (get-char-code-property
181 char 'decomposition))
182 (if (and ccc (/= 0 ccc)) (add-to-list 'combining-chars char))
183 (if (and (numberp (car decomposition))
184 (/= (ucs-normalize-ccc (car decomposition))
186 (add-to-list 'non-starter-decompositions char))
187 (when (numberp (car decomposition))
188 (if (and (= 2 (length decomposition))
189 (null (memq char ucs-normalize-composition-exclusions))
190 (null (memq char non-starter-decompositions)))
191 (setq decomposition-pair-to-composition
192 (cons (cons decomposition char)
193 decomposition-pair-to-composition)))
194 ;; If not singleton decomposition, second and later characters in
195 ;; decomposition will be the subject of combining characters.
196 (if (cdr decomposition)
197 (dolist (char (cdr decomposition))
198 (add-to-list 'combining-chars char))))))
201 (setq combining-chars
202 (append combining-chars
203 '(?ᅡ ?ᅢ ?ᅣ ?ᅤ ?ᅥ ?ᅦ ?ᅧ ?ᅨ ?ᅩ ?ᅪ
204 ?ᅫ ?ᅬ ?ᅭ ?ᅮ ?ᅯ ?ᅰ ?ᅱ ?ᅲ ?ᅳ ?ᅴ ?ᅵ
205 ?ᆨ ?ᆩ ?ᆪ ?ᆫ ?ᆬ ?ᆭ ?ᆮ ?ᆯ ?ᆰ ?ᆱ ?ᆲ ?ᆳ ?ᆴ
206 ?ᆵ ?ᆶ ?ᆷ ?ᆸ ?ᆹ ?ᆺ ?ᆻ ?ᆼ ?ᆽ ?ᆾ ?ᆿ ?ᇀ ?ᇁ ?ᇂ)))
210 (defun ucs-normalize-make-hash-table-from-alist (alist)
211 (let ((table (make-hash-table :test 'equal :size 2000)))
212 (mapc (lambda (x) (puthash (car x) (cdr x) table)) alist)
215 (defvar ucs-normalize-decomposition-pair-to-primary-composite nil
216 "Hashtable of decomposed pair to primary composite.
217 Note that Hangul are excluded.")
218 (setq ucs-normalize-decomposition-pair-to-primary-composite
219 (ucs-normalize-make-hash-table-from-alist
220 (eval-when-compile decomposition-pair-to-composition)))
222 (defun ucs-normalize-primary-composite (decomposition-pair composition-predicate)
223 "Convert DECOMPOSITION-PAIR to primay composite using COMPOSITION-PREDICATE."
224 (let ((char (or (gethash decomposition-pair
225 ucs-normalize-decomposition-pair-to-primary-composite)
226 (and (<= #x1100 (car decomposition-pair))
227 (< (car decomposition-pair) #x1113)
228 (<= #x1161 (cadr decomposition-pair))
229 (< (car decomposition-pair) #x1176)
230 (let ((lindex (- (car decomposition-pair) #x1100))
231 (vindex (- (cadr decomposition-pair) #x1161)))
232 (+ #xAC00 (* (+ (* lindex 21) vindex) 28))))
233 (and (<= #xac00 (car decomposition-pair))
234 (< (car decomposition-pair) #xd7a4)
235 (<= #x11a7 (cadr decomposition-pair))
236 (< (cadr decomposition-pair) #x11c3)
237 (= 0 (% (- (car decomposition-pair) #xac00) 28))
238 (let ((tindex (- (cadr decomposition-pair) #x11a7)))
239 (+ (car decomposition-pair) tindex))))))
241 (functionp composition-predicate)
242 (null (funcall composition-predicate char)))
246 (defvar ucs-normalize-combining-chars nil)
247 (setq ucs-normalize-combining-chars (eval-when-compile combining-chars))
249 (defvar ucs-normalize-combining-chars-regexp nil
250 "Regular expression to match sequence of combining characters.")
251 (setq ucs-normalize-combining-chars-regexp
252 (eval-when-compile (concat (regexp-opt (mapcar 'char-to-string combining-chars)) "+")))
256 (defun decomposition-translation-alist (decomposition-function)
257 (let (decomposition alist)
260 (do ((char (car start-end) (+ char 1))) ((> char (cdr start-end)))
261 (setq decomposition (funcall decomposition-function char))
263 (setq alist (cons (cons char
266 (decomposition-char-recursively
267 x decomposition-function))
273 (defun decomposition-char-recursively (char decomposition-function)
274 (let ((decomposition (funcall decomposition-function char)))
278 (decomposition-char-recursively x decomposition-function))
282 (defun alist-list-to-vector (alist)
283 (mapcar (lambda (x) (cons (car x) (apply 'vector (cdr x)))) alist))
285 (defvar nfd-alist nil)
286 (setq nfd-alist (alist-list-to-vector (decomposition-translation-alist 'nfd)))
287 (defvar nfkd-alist nil)
288 (setq nfkd-alist (alist-list-to-vector (decomposition-translation-alist 'nfkd)))
289 (defvar hfs-nfd-alist nil)
290 (setq hfs-nfd-alist (alist-list-to-vector (decomposition-translation-alist 'hfs-nfd)))
294 (defvar ucs-normalize-hangul-translation-alist nil)
295 (setq ucs-normalize-hangul-translation-alist
299 (cons (cons (+ #xac00 i)
301 (vector (+ #x1100 (/ i 588))
302 (+ #x1161 (/ (% i 588) 28)))
303 (vector (+ #x1100 (/ i 588))
304 (+ #x1161 (/ (% i 588) 28))
305 (+ #x11a7 (% i 28)))))
309 (defun ucs-normalize-make-translation-table-from-alist (alist)
310 (make-translation-table-from-alist
311 (append alist ucs-normalize-hangul-translation-alist)))
313 (define-translation-table 'ucs-normalize-nfd-table
314 (ucs-normalize-make-translation-table-from-alist (eval-when-compile nfd-alist)))
315 (define-translation-table 'ucs-normalize-nfkd-table
316 (ucs-normalize-make-translation-table-from-alist (eval-when-compile nfkd-alist)))
317 (define-translation-table 'ucs-normalize-hfs-nfd-table
318 (ucs-normalize-make-translation-table-from-alist (eval-when-compile hfs-nfd-alist)))
320 (defun ucs-normalize-sort (chars)
321 "Sort by canonical combining class of chars."
324 (< (ucs-normalize-ccc ch1) (ucs-normalize-ccc ch2)))))
326 (defun ucs-normalize-compose-chars (chars composition-predicate)
327 "Compose CHARS by COMPOSITION-PREDICATE.
328 CHARS must be sorted and normalized in starter-combining pairs."
329 (if composition-predicate
330 (let* ((starter (car chars))
331 remain result prev-ccc
332 (target-chars (cdr chars))
336 (setq target (car target-chars)
337 target-ccc (ucs-normalize-ccc target))
338 (if (and (or (null prev-ccc)
339 (< prev-ccc target-ccc))
340 (setq primary-composite
341 (ucs-normalize-primary-composite (list starter target)
342 composition-predicate)))
343 ;; case 1: composable
344 (setq starter primary-composite
347 ;; case 2: move starter
348 (setq result (nconc result (cons starter (nreverse remain)))
351 ;; case 3: move target
352 (setq prev-ccc target-ccc
353 remain (cons target remain))))
354 (setq target-chars (cdr target-chars)))
355 (nconc result (cons starter (nreverse remain))))
358 (defun ucs-normalize-block-compose-chars (chars composition-predicate)
359 "Try composing CHARS by COMPOSITION-PREDICATE.
360 If COMPOSITION-PREDICATE is not given, then do nothing."
361 (let ((chars (ucs-normalize-sort chars)))
362 (if composition-predicate
363 (ucs-normalize-compose-chars chars composition-predicate)
369 (defun quick-check-list (decomposition-translation
370 &optional composition-predicate)
371 "Quick-Check List for DECOMPOSITION-TRANSLATION and COMPOSITION-PREDICATE.
372 It includes Singletons, CompositionExclusions, and Non-Starter
374 (let (entries decomposition composition)
377 (do ((i (car start-end) (+ i 1))) ((> i (cdr start-end)))
382 (translate-region 1 2 decomposition-translation)
385 (ucs-normalize-block-compose-chars decomposition composition-predicate))
386 (when (not (equal composition (list i)))
387 (setq entries (cons i entries)))))
391 ucs-normalize-composition-exclusions
392 non-starter-decompositions)))
395 (defvar nfd-quick-check-list nil)
396 (setq nfd-quick-check-list (quick-check-list 'ucs-normalize-nfd-table ))
397 (defvar nfc-quick-check-list nil)
398 (setq nfc-quick-check-list (quick-check-list 'ucs-normalize-nfd-table t ))
399 (defvar nfkd-quick-check-list nil)
400 (setq nfkd-quick-check-list (quick-check-list 'ucs-normalize-nfkd-table ))
401 (defvar nfkc-quick-check-list nil)
402 (setq nfkc-quick-check-list (quick-check-list 'ucs-normalize-nfkd-table t ))
403 (defvar hfs-nfd-quick-check-list nil)
404 (setq hfs-nfd-quick-check-list (quick-check-list 'ucs-normalize-hfs-nfd-table
405 'ucs-normalize-hfs-nfd-comp-p))
406 (defvar hfs-nfc-quick-check-list nil)
407 (setq hfs-nfc-quick-check-list (quick-check-list 'ucs-normalize-hfs-nfd-table t ))
409 (defun quick-check-list-to-regexp (quick-check-list)
410 (regexp-opt (mapcar 'char-to-string (append quick-check-list combining-chars))))
412 (defun quick-check-decomposition-list-to-regexp (quick-check-list)
413 (concat (quick-check-list-to-regexp quick-check-list) "\\|[가-힣]"))
415 (defun quick-check-composition-list-to-regexp (quick-check-list)
416 (concat (quick-check-list-to-regexp quick-check-list) "\\|[ᅡ-ᅵᆨ-ᇂ]"))
421 (defvar ucs-normalize-nfd-quick-check-regexp nil)
422 (setq ucs-normalize-nfd-quick-check-regexp
423 (eval-when-compile (quick-check-decomposition-list-to-regexp nfd-quick-check-list)))
424 (defvar ucs-normalize-nfc-quick-check-regexp nil)
425 (setq ucs-normalize-nfc-quick-check-regexp
426 (eval-when-compile (quick-check-composition-list-to-regexp nfc-quick-check-list)))
429 (defvar ucs-normalize-nfkd-quick-check-regexp nil)
430 (setq ucs-normalize-nfkd-quick-check-regexp
431 (eval-when-compile (quick-check-decomposition-list-to-regexp nfkd-quick-check-list)))
432 (defvar ucs-normalize-nfkc-quick-check-regexp nil)
433 (setq ucs-normalize-nfkc-quick-check-regexp
434 (eval-when-compile (quick-check-composition-list-to-regexp nfkc-quick-check-list)))
437 (defvar ucs-normalize-hfs-nfd-quick-check-regexp nil)
438 (setq ucs-normalize-hfs-nfd-quick-check-regexp
439 (eval-when-compile (concat (quick-check-decomposition-list-to-regexp hfs-nfd-quick-check-list))))
440 (defvar ucs-normalize-hfs-nfc-quick-check-regexp nil)
441 (setq ucs-normalize-hfs-nfc-quick-check-regexp
442 (eval-when-compile (quick-check-composition-list-to-regexp hfs-nfc-quick-check-list)))
444 ;;------------------------------------------------------------------------------------------
446 ;; Normalize local region.
448 (defun ucs-normalize-block
449 (from to &optional decomposition-translation-table composition-predicate)
450 "Normalize region FROM TO, by sorting the region with canonical-cc.
451 If DECOMPOSITION-TRANSLATION-TABLE is given, translate region
452 before sorting. If COMPOSITION-PREDICATE is given, then compose
453 the region by using it."
455 (narrow-to-region from to)
456 (goto-char (point-min))
457 (if decomposition-translation-table
458 (translate-region from to decomposition-translation-table))
459 (goto-char (point-min))
460 (let ((start (point)) chars); ccc)
464 (= 0 (ucs-normalize-ccc (char-after (point)))))
467 (ucs-normalize-block-compose-chars
468 (string-to-list (buffer-substring start (point)))
469 composition-predicate))
471 ;;(unless ccc (error "Undefined character can not be normalized!"))
473 (delete-region (point-min) (point-max))
475 (ucs-normalize-compose-chars
476 chars composition-predicate)))))
478 (defun ucs-normalize-region
479 (from to quick-check-regexp translation-table composition-predicate)
480 "Normalize region from FROM to TO.
481 QUICK-CHECK-REGEXP is applied for searching the region.
482 TRANSLATION-TABLE will be used to decompose region.
483 COMPOSITION-PREDICATE will be used to compose region."
486 (narrow-to-region from to)
487 (goto-char (point-min))
488 (let (start-pos starter)
489 (while (re-search-forward quick-check-regexp nil t)
490 (setq starter (string-to-char (match-string 0)))
491 (setq start-pos (match-beginning 0))
494 (if (or (= start-pos (point-min))
495 (and (= 0 (ucs-normalize-ccc starter))
496 (not (memq starter ucs-normalize-combining-chars))))
497 start-pos (1- start-pos))
499 (if (looking-at ucs-normalize-combining-chars-regexp)
500 (match-end 0) (1+ start-pos))
501 translation-table composition-predicate))))))
503 ;; --------------------------------------------------------------------------------
505 (defmacro ucs-normalize-string (ucs-normalize-region)
508 (,ucs-normalize-region (point-min) (point-max))
512 (defun ucs-normalize-NFD-region (from to)
513 "Normalize the current region by the Unicode NFD."
515 (ucs-normalize-region from to
516 ucs-normalize-nfd-quick-check-regexp
517 'ucs-normalize-nfd-table nil))
519 (defun ucs-normalize-NFD-string (str)
520 "Normalize the string STR by the Unicode NFD."
521 (ucs-normalize-string ucs-normalize-NFD-region))
524 (defun ucs-normalize-NFC-region (from to)
525 "Normalize the current region by the Unicode NFC."
527 (ucs-normalize-region from to
528 ucs-normalize-nfc-quick-check-regexp
529 'ucs-normalize-nfd-table t))
531 (defun ucs-normalize-NFC-string (str)
532 "Normalize the string STR by the Unicode NFC."
533 (ucs-normalize-string ucs-normalize-NFC-region))
536 (defun ucs-normalize-NFKD-region (from to)
537 "Normalize the current region by the Unicode NFKD."
539 (ucs-normalize-region from to
540 ucs-normalize-nfkd-quick-check-regexp
541 'ucs-normalize-nfkd-table nil))
543 (defun ucs-normalize-NFKD-string (str)
544 "Normalize the string STR by the Unicode NFKD."
545 (ucs-normalize-string ucs-normalize-NFKD-region))
548 (defun ucs-normalize-NFKC-region (from to)
549 "Normalize the current region by the Unicode NFKC."
551 (ucs-normalize-region from to
552 ucs-normalize-nfkc-quick-check-regexp
553 'ucs-normalize-nfkd-table t))
555 (defun ucs-normalize-NFKC-string (str)
556 "Normalize the string STR by the Unicode NFKC."
557 (ucs-normalize-string ucs-normalize-NFKC-region))
560 (defun ucs-normalize-HFS-NFD-region (from to)
561 "Normalize the current region by the Unicode NFD and Mac OS's HFS Plus."
563 (ucs-normalize-region from to
564 ucs-normalize-hfs-nfd-quick-check-regexp
565 'ucs-normalize-hfs-nfd-table
566 'ucs-normalize-hfs-nfd-comp-p))
568 (defun ucs-normalize-HFS-NFD-string (str)
569 "Normalize the string STR by the Unicode NFD and Mac OS's HFS Plus."
570 (ucs-normalize-string ucs-normalize-HFS-NFD-region))
572 (defun ucs-normalize-HFS-NFC-region (from to)
573 "Normalize the current region by the Unicode NFC and Mac OS's HFS Plus."
575 (ucs-normalize-region from to
576 ucs-normalize-hfs-nfc-quick-check-regexp
577 'ucs-normalize-hfs-nfd-table t))
579 (defun ucs-normalize-HFS-NFC-string (str)
580 "Normalize the string STR by the Unicode NFC and Mac OS's HFS Plus."
581 (ucs-normalize-string ucs-normalize-HFS-NFC-region))
583 ;; Post-read-conversion function for `utf-8-hfs'.
584 (defun ucs-normalize-hfs-nfd-post-read-conversion (len)
587 (narrow-to-region (point) (+ (point) len))
588 (let ((buffer-modified-p (buffer-modified-p)))
589 (ucs-normalize-HFS-NFC-region (point-min) (point-max))
590 (- (point-max) (point-min))))))
592 ;;; coding-system definition
593 (define-coding-system 'utf-8-hfs
594 "UTF-8 base coding system with normalization on decoding.
595 The singleton characters in HFS normalization exclusion will not
596 be decomposed. It doesn't perform normalization on encoding."
599 :charset-list '(unicode)
600 ;; :decode-translation-table (not necessary)
601 :post-read-conversion 'ucs-normalize-hfs-nfd-post-read-conversion
602 ;; NFD encoder is not necessary because MacOS will automatically do it.
603 ;; :encode-translation-table 'nfd-encode-translation-table
604 ;; :pre-write-conversion 'nfd-encode-function
607 (provide 'ucs-normalize)
613 ;; arch-tag: cef65ae7-71ad-4e19-8da8-56ab4d42aaa4
614 ;;; ucs-normalize.el ends here