1 ;;; ideo-trans.el --- Translation utility for Ideographic Strings
3 ;; Copyright (C) 2003,2004,2005,2008,2012 MORIOKA Tomohiko
5 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
6 ;; Keywords: Ideographs, Character Database, Chaon, CHISE
8 ;; This file is a part of tomoyo-tools.
10 ;; This program is free software; you can redistribute it and/or
11 ;; modify it under the terms of the GNU General Public License as
12 ;; published by the Free Software Foundation; either version 2, or (at
13 ;; your option) any later version.
15 ;; This program is distributed in the hope that it will be useful, but
16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 ;; General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with this program; see the file COPYING. If not, write to
22 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
27 (defun char-cns11643-p (char &optional defined-only)
30 (intern (format "=cns11643-%d" n))
34 (defun char-ks-x1001-p (char &optional defined-only)
35 (encode-char char 'korean-ksc5601 defined-only))
37 (defun find-char-variant (char predicate)
38 (if (funcall predicate char)
40 (let ((ucs (char-ucs char))
44 (char-variants (decode-char 'ucs ucs))))
46 (setq char (car variants))
47 (not (funcall predicate char)))
48 (setq variants (cdr variants))))
52 (defun char-representative-of-ucs (char)
53 "Convert CHAR into representative character of UCS."
55 (if (setq ret (char-ucs char))
56 (decode-char '=ucs ret)
60 (defun char-representative-of-domain (char domain)
61 "Convert CHAR into representative character of DOMAIN."
63 (cond ((eq domain 'daikanwa)
64 (char-representative-of-daikanwa char))
66 (char-representative-of-ucs char))
68 (if (setq ret (char-feature char '=>ucs@cns))
69 (decode-char '=ucs@cns ret)
70 (find-char-variant char 'char-cns11643-p)))
72 (if (setq ret (char-feature char '=>ucs@ks))
73 (decode-char '=ucs@ks ret)
74 (find-char-variant char 'char-ks-x1001-p)))
76 (or (char-feature char
77 (intern (format "=>ucs@%s" domain)))
79 (decode-char (intern (format "=ucs@%s" domain)) ret))
83 (defun ideo-translate-string-into-ucs (string)
84 "Convert characters in STRING into UCS-representative characters."
85 (mapconcat (lambda (char)
86 (char-to-string (char-representative-of-ucs char)))
90 (defun chinese-simplify-string (string)
91 "Simplify Chinese traditional characters in STRING."
96 (cond ((setq ret (char-feature chr '=>ucs@gb))
97 (setq chr (decode-char '=ucs@gb ret)))
98 ((setq ret (char-ucs chr))
99 (setq chr (decode-char '=ucs@gb ret))
100 (if (setq ret (char-feature chr '=>ucs*))
101 (setq chr (decode-char '=ucs@gb ret))
105 (if (setq ret (encode-char uchr 'chinese-gb12345))
106 (decode-char 'chinese-gb2312 ret)
111 (define-obsolete-function-alias
112 'ideo-translate-string-into-simplified-chinese
113 'chinese-simplify-string)
116 (define-obsolete-function-alias 'ideo-trans-simplify-chinese-string
117 'chinese-simplify-string)
120 (defvar japanese-simplified-relation-features
121 '(->simplified@JP/Jouyou
122 ->simplified@jp-jouyou
123 ;; ->simplified@JP/extra
124 ;; ->simplified@JP/extra/design
125 ;; ->simplified@JP/jis
126 ;; ->simplified@JP/jis/2004
127 ;; ->simplified@JP/jis/1978
128 ;; ->simplified@JP/misc
133 ;; ->simplified@JP/old
134 ;; ->simplified@JP/buddhism
136 "List of relation features to map traditional Kanji to simplified Kanji used in Japanese.")
139 (defvar japanese-traditional-relation-features
140 '(<-simplified@JP/Jouyou
141 <-simplified@jp-jouyou
142 <-simplified@JP/extra
143 <-simplified@JP/extra/design
145 <-simplified@JP/jis/2004
146 <-simplified@JP/jis/1978
152 ;; <-simplified@JP/old
153 ;; <-simplified@JP/buddhism
155 "List of relation features to map simplified Kanji to traditional Kanji used in Japanese.")
158 (defun japanese-simplify-string (string)
159 "Simplify traditional Kanji characters in STRING."
164 (cond ((setq ret (char-feature chr '=>ucs@jis))
165 (setq chr (decode-char '=ucs@jis ret)))
166 ((setq ret (char-ucs chr))
167 (setq chr (decode-char '=ucs@jis ret))
168 (if (setq ret (char-feature chr '=>ucs*))
169 (setq chr (decode-char '=ucs@jis ret))
172 (setq rest japanese-simplified-relation-features)
174 (null (setq ret (char-feature chr (car rest)))))
175 (setq rest (cdr rest)))
178 ((setq ret (char-feature chr '=>ucs@jis))
179 (decode-char '=ucs@jis ret))
180 ((setq ret (char-ucs chr))
181 (decode-char '=ucs@JP ret))
186 (define-obsolete-function-alias
187 'ideo-translate-string-into-simplified-japanese
188 'japanese-simplify-string)
191 (defun ideo-trans-select-char (chars &optional prefix)
197 (mapconcat (lambda (cell)
199 (format "%d. %c" i cell))
202 (while (and (setq ret (string-to-int (read-string prompt)))
204 (<= ret (length chars))))))
205 (nth (1- ret) chars)))
208 (defun chinese-traditionalize-string (string &optional selector)
209 "Convert simplified Chinese characters in STRING to traditional characters."
213 (ideo-trans-select-char chars (format "%c => " chr)))))
218 (cond ((car (char-feature chr '<-simplified))
220 (funcall selector ret)
224 (cond ((setq ret (char-feature chr '=>ucs@gb))
225 (decode-char '=ucs@gb ret))
226 ((setq ret (char-ucs chr))
227 (decode-char '=ucs@gb ret))
229 (if (setq ret (encode-char ret 'chinese-gb2312))
230 (setq ret (decode-char 'chinese-gb12345 ret))))
236 (define-obsolete-function-alias
237 'ideo-translate-chinese-string-into-traditional
238 'chinese-traditionalize-string)
241 (defun japanese-traditionalize-string (string &optional selector)
242 "Convert simplified Kanji in STRING into traditional characters."
246 (ideo-trans-select-char chars (format "%c => " chr)))))
250 (setq rest japanese-traditional-relation-features)
252 (null (setq ret (char-feature chr (car rest)))))
253 (setq rest (cdr rest)))
257 (funcall selector ret)
261 (cond ((setq ret (char-feature chr '=>ucs@jis))
262 (decode-char '=ucs@jis ret))
263 ((setq ret (char-ucs chr))
264 (decode-char '=ucs@JP ret))
266 (setq ret (or (char-feature ret '<-simplified@JP/Jouyou)
267 (char-feature ret '<-simplified@JP))))
269 (ideo-trans-select-char ret (format "%c => " chr))
271 ((setq ret (char-feature chr '=>ucs@jis))
272 (decode-char '=ucs@jis ret))
273 ((setq ret (char-ucs chr))
274 (decode-char '=ucs@JP ret))
279 (define-obsolete-function-alias
280 'ideo-translate-japanese-string-into-traditional
281 'japanese-traditionalize-string)
284 (defun japanese-traditionalize-region (start end)
288 (narrow-to-region start end)
290 (let (chr ret rret rest)
291 (while (and (skip-chars-forward "\x00-\xFF")
293 (setq chr (char-after))
294 (setq rest japanese-traditional-relation-features)
296 (null (setq ret (char-feature chr (car rest)))))
297 (setq rest (cdr rest)))
302 (setq rret (ideo-trans-select-char ret))
308 (forward-char))))))))
311 (defun japanese-simplify-region (start end)
315 (narrow-to-region start end)
317 (let (chr ret rret rest)
318 (while (and (skip-chars-forward "\x00-\xFF")
320 (setq chr (char-after))
321 (setq rest japanese-simplified-relation-features)
323 (null (setq ret (char-feature chr (car rest)))))
324 (setq rest (cdr rest)))
329 (setq rret (ideo-trans-select-char ret))
335 (forward-char))))))))
338 (define-obsolete-function-alias
339 'ideo-translate-japanese-region-into-traditional
340 'japanese-traditionalize-region)
343 (define-obsolete-function-alias
344 'ideo-translate-region-into-traditional
345 'japanese-traditionalize-region)
351 (provide 'ideo-trans)
353 ;;; ideo-trans.el ends here