dad8d0bc9aad2b914de82d275f1113289114353f
[chise/tomoyo-tools.git] / ideo-trans.el
1 ;;; ideo-trans.el --- Translation utility for Ideographic Strings
2
3 ;; Copyright (C) 2003,2004 MORIOKA Tomohiko
4
5 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
6 ;; Keywords: Ideographs, Character Database, Chaon, CHISE
7
8 ;; This file is a part of tomoyo-tools.
9
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.
14
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.
19
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.
24
25 ;;; Code:
26
27 (defun char-cns11643-p (char &optional defined-only)
28   (some (lambda (n)
29           (encode-char char
30                        (intern (format "=cns11643-%d" n))
31                        defined-only))
32         '(1 2 3 4 5 6 7)))
33
34 (defun char-ks-x1001-p (char &optional defined-only)
35   (encode-char char 'korean-ksc5601 defined-only))
36
37 (defun find-char-variant (char predicate)
38   (if (funcall predicate char)
39       char
40     (let ((ucs (char-ucs char))
41           variants)
42       (if (and ucs
43                (setq variants
44                      (char-variants (decode-char 'ucs ucs))))
45           (while (and variants
46                       (setq char (car variants))
47                       (not (funcall predicate char)))
48             (setq variants (cdr variants))))
49       char)))
50
51 ;;;###autoload
52 (defun char-representative-of-ucs (char)
53   "Convert CHAR into representative character of UCS."
54   (let (ret)
55     (if (setq ret (char-ucs char))
56         (decode-char '=ucs ret)
57       char)))
58
59 ;;;###autoload
60 (defun char-representative-of-domain (char domain)
61   "Convert CHAR into representative character of DOMAIN."
62   (let (ret)
63     (cond ((eq domain 'daikanwa)
64            (char-representative-of-daikanwa char))
65           ((eq domain 'ucs)
66            (char-representative-of-ucs char))
67           ((eq domain 'cns)
68            (if (setq ret (char-feature char '=>ucs@cns))
69                (decode-char '=ucs@cns ret)
70              (find-char-variant char 'char-cns11643-p)))
71           ((eq domain 'ks)
72            (if (setq ret (char-feature char '=>ucs@ks))
73                (decode-char '=ucs@ks ret)
74              (find-char-variant char 'char-ks-x1001-p)))
75           ((setq ret
76                  (or (char-feature char
77                                    (intern (format "=>ucs@%s" domain)))
78                      (char-ucs char)))
79            (decode-char (intern (format "=ucs@%s" domain)) ret))
80           (t char))))
81
82 ;;;###autoload
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)))
87              string ""))
88
89 ;;;###autoload
90 (defun chinese-simplify-string (string)
91   "Simplify Chinese traditional characters in STRING."
92   (let (uchr ret)
93     (mapconcat
94      (lambda (chr)
95        (setq uchr
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 (get-char-attribute chr '=>ucs*))
101                         (decode-char '=ucs@gb ret)
102                       chr))
103                    (t chr)))
104        (char-to-string
105         (if (setq ret (encode-char uchr 'chinese-gb12345))
106             (decode-char 'chinese-gb2312 ret)
107           chr)))
108      string "")))
109
110 ;;;###autoload
111 (define-obsolete-function-alias
112   'ideo-translate-string-into-simplified-chinese
113   'chinese-simplify-string)
114
115 ;;;###autoload
116 (define-obsolete-function-alias 'ideo-trans-simplify-chinese-string
117   'chinese-simplify-string)
118
119 ;;;###autoload
120 (defun japanese-simplify-string (string)
121   "Simplify traditional Kanji characters in STRING."
122   (let (ret)
123     (mapconcat
124      (lambda (chr)
125        (setq ret (or (char-feature chr '->simplified@JP/Jouyou)
126                      (char-feature chr '->simplified@JP)
127                      (char-feature chr '->simplified)))
128        (char-to-string
129         (cond ((car ret))
130               ((setq ret (char-feature chr '=>ucs@jis))
131                (decode-char '=ucs@jis ret))
132               ((setq ret (char-ucs chr))
133                (decode-char '=ucs@jp ret))
134               (t chr))))
135      string "")))
136
137 ;;;###autoload
138 (define-obsolete-function-alias
139   'ideo-translate-string-into-simplified-japanese
140   'japanese-simplify-string)
141
142
143 (defun ideo-trans-select-char (chars &optional prefix)
144   (let ((i 0)
145         prompt ret)
146     (setq prompt
147           (concat
148            prefix
149            (mapconcat (lambda (cell)
150                         (setq i (1+ i))
151                         (format "%d. %c" i cell))
152                       chars " ")
153            " : "))
154     (while (and (setq ret (string-to-int (read-string prompt)))
155                 (not (and (< 0 ret)
156                           (<=  ret (length chars))))))
157     (nth (1- ret) chars)))
158
159 ;;;###autoload
160 (defun chinese-traditionalize-string (string)
161   "Convert simplified Chinese characters in STRING to traditional characters."
162   (let (ret)
163     (mapconcat
164      (lambda (chr)
165        (char-to-string
166         (cond ((car (char-feature chr '<-simplified))
167                (if (cdr ret)
168                    (ideo-trans-select-char ret (format "%c => " chr))
169                  (car ret)))
170               ((progn
171                  (setq ret
172                        (cond ((setq ret (char-feature chr '=>ucs@gb))
173                               (decode-char '=ucs@gb ret))
174                              ((setq ret (char-ucs chr))
175                               (decode-char '=ucs@gb ret))
176                              (t chr)))
177                  (if (setq ret (encode-char ret 'chinese-gb2312))
178                      (setq ret (decode-char 'chinese-gb12345 ret))))
179                ret)
180               (t chr))))
181      string "")))
182
183 ;;;###autoload
184 (define-obsolete-function-alias
185   'ideo-translate-chinese-string-into-traditional
186   'chinese-traditionalize-string)
187
188 ;;;###autoload
189 (defun japanese-traditionalize-string (string)
190   "Convert simplified Kanji in STRING into traditional characters."
191   (let (ret)
192     (mapconcat
193      (lambda (chr)
194        (char-to-string
195         (cond ((setq ret (char-feature chr '<-simplified))
196                (if (cdr ret)
197                    (ideo-trans-select-char ret (format "%c => " chr))
198                  (car ret)))
199               ((progn
200                  (setq ret
201                        (cond ((setq ret (char-feature chr '=>ucs@jis))
202                               (decode-char '=ucs@jis ret))
203                              ((setq ret (char-ucs chr))
204                               (decode-char '=ucs@jp ret))
205                              (t chr)))
206                  (setq ret (or (char-feature ret '<-simplified@JP/Jouyou)
207                                (char-feature ret '<-simplified@JP))))
208                (if (cdr ret)
209                    (ideo-trans-select-char ret (format "%c => " chr))
210                  (car ret)))
211               ((setq ret (char-feature chr '=>ucs@jis))
212                (decode-char '=ucs@jis ret))
213               ((setq ret (char-ucs chr))
214                (decode-char '=ucs@jp ret))
215               (t chr))))
216      string "")))
217                       
218 ;;;###autoload
219 (define-obsolete-function-alias
220   'ideo-translate-japanese-string-into-traditional
221   'japanese-traditionalize-string)
222
223 ;;;###autoload
224 (defun japanese-traditionalize-region (start end)
225   (interactive "r")
226   (save-excursion
227     (save-restriction
228       (narrow-to-region start end)
229       (goto-char start)
230       (let (chr ret rret)
231         (while (and (skip-chars-forward "\x00-\xFF")
232                     (not (eobp)))
233           (setq chr (char-after))
234           (if (setq ret (or (get-char-attribute chr '<-simplified@JP/Jouyou)
235                             (get-char-attribute chr '<-simplified@jp-jouyou)
236                             (get-char-attribute chr '<-simplified@JP)
237                             (get-char-attribute chr '<-simplified@jp)
238                             (get-char-attribute chr '<-jp-simplified)
239                             (get-char-attribute chr '<-simplified)))
240               (progn
241                 (if (cdr ret)
242                     (progn
243                       (setq rret (ideo-trans-select-char ret))
244                       (delete-char)
245                       (insert rret))
246                   (delete-char)
247                   (insert (car ret))))
248             (or (eobp)
249                 (forward-char))))))))
250
251 ;;;###autoload
252 (defun japanese-simplify-region (start end)
253   (interactive "r")
254   (save-excursion
255     (save-restriction
256       (narrow-to-region start end)
257       (goto-char start)
258       (let (chr ret rret)
259         (while (and (skip-chars-forward "\x00-\xFF")
260                     (not (eobp)))
261           (setq chr (char-after))
262           (if (setq ret (or (get-char-attribute chr '->simplified@JP/Jouyou)
263                             (get-char-attribute chr '->simplified@jp-jouyou)
264                             (get-char-attribute chr '->simplified@JP)
265                             (get-char-attribute chr '->simplified@jp)
266                             (get-char-attribute chr '->jp-simplified)
267                             (get-char-attribute chr '->simplified)))
268               (progn
269                 (if (cdr ret)
270                     (progn
271                       (setq rret (ideo-trans-select-char ret))
272                       (delete-char)
273                       (insert rret))
274                   (delete-char)
275                   (insert (car ret))))
276             (or (eobp)
277                 (forward-char))))))))
278
279 ;;;###autoload
280 (define-obsolete-function-alias
281   'ideo-translate-japanese-region-into-traditional
282   'japanese-traditionalize-region)
283
284 ;;;###autoload
285 (define-obsolete-function-alias
286   'ideo-translate-region-into-traditional
287   'japanese-traditionalize-region)
288
289
290 ;;; @ End.
291 ;;;
292
293 (provide 'ideo-trans)
294
295 ;;; ideo-trans.el ends here