1 ;;; ideo-trans.el --- Translation utility for Ideographic Strings
3 ;; Copyright (C) 2003,2004 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."
54 (if (setq ret (char-ucs char))
55 (decode-char '=ucs ret)
59 (defun char-representative-of-domain (char domain)
60 "Convert CHAR into representative character of DOMAIN."
62 (cond ((eq domain 'daikanwa)
63 (char-representative-of-daikanwa char))
65 (char-representative-of-ucs char))
67 (if (setq ret (char-feature char '=>ucs@cns))
68 (decode-char '=ucs@cns ret)
69 (find-char-variant char 'char-cns11643-p)))
71 (if (setq ret (char-feature char '=>ucs@ks))
72 (decode-char '=ucs@ks ret)
73 (find-char-variant char 'char-ks-x1001-p)))
75 (or (char-feature char
76 (intern (format "=>ucs@%s" domain)))
78 (decode-char (intern (format "=ucs@%s" domain)) ret))
82 (defun ideo-translate-string-into-ucs (string)
83 "Convert characters in STRING into UCS-representative characters."
84 (mapconcat (lambda (char)
85 (char-to-string (char-representative-of-ucs char)))
89 (defun ideo-translate-string-into-simplified-chinese (string)
90 "Simplify Chinese traditional characters in STRING."
95 (cond ((setq ret (char-feature chr '=>ucs@gb))
96 (setq chr (decode-char '=ucs@gb ret)))
97 ((setq ret (char-ucs chr))
98 (setq chr (decode-char '=ucs@gb ret))
99 (if (setq ret (get-char-attribute chr '=>ucs*))
100 (decode-char '=ucs@gb ret)
104 (if (setq ret (encode-char uchr 'chinese-gb12345))
105 (decode-char 'chinese-gb2312 ret)
110 (define-obsolete-function-alias 'ideo-trans-simplify-chinese-string
111 'ideo-translate-string-into-simplified-chinese)
114 (defun ideo-translate-string-into-simplified-japanese (string)
115 "Simplify traditional Kanji characters in STRING."
119 (setq ret (or (char-feature chr '->simplified@JP/Jouyou)
120 (char-feature chr '->simplified@JP)
121 (char-feature chr '->simplified)))
124 ((setq ret (char-feature chr '=>ucs@jis))
125 (decode-char '=ucs@jis ret))
126 ((setq ret (char-ucs chr))
127 (decode-char '=ucs@jp ret))
132 (defun ideo-translate-string-into-traditional (string)
133 "Convert simplified Kanji in STRING into traditional characters."
138 (cond ((car (char-feature chr '<-simplified)))
141 (cond ((setq ret (char-feature chr '=>ucs@jis))
142 (decode-char '=ucs@jis ret))
143 ((setq ret (char-ucs chr))
144 (decode-char '=ucs@jp ret))
146 (setq ret (or (char-feature ret '<-simplified@JP/Jouyou)
147 (char-feature ret '<-simplified@JP))))
151 (cond ((setq ret (char-feature chr '=>ucs@gb))
152 (decode-char '=ucs@gb ret))
153 ((setq ret (char-ucs chr))
154 (decode-char '=ucs@gb ret))
156 (if (setq ret (encode-char ret 'chinese-gb2312))
157 (setq ret (decode-char 'chinese-gb12345 ret))))
159 ((setq ret (char-feature chr '=>ucs@jis))
160 (decode-char '=ucs@jis ret))
161 ((setq ret (char-ucs chr))
162 (decode-char '=ucs@jp ret))
167 (defun ideo-translate-region-into-traditional (start end)
171 (narrow-to-region start end)
173 (let (chr ret rret i prompt)
174 (while (and (skip-chars-forward "\x00-\xFF")
176 (setq chr (char-after))
177 (if (setq ret (or (get-char-attribute chr '<-simplified@JP/Jouyou)
178 (get-char-attribute chr '<-simplified@jp-jouyou)
179 (get-char-attribute chr '<-simplified@JP)
180 (get-char-attribute chr '<-simplified@jp)
181 (get-char-attribute chr '<-jp-simplified)
182 (get-char-attribute chr '<-simplified)))
189 (mapconcat (lambda (cell)
191 (format "%d. %c" i cell))
194 (while (and (setq rret
196 (read-string prompt)))
198 (<= rret (length ret))))))
200 (insert (nth (1- rret) ret)))
204 (forward-char))))))))
210 (provide 'ideo-trans)
212 ;;; ideo-trans.el ends here