(char-cns11643-p): New function [copied from ids/ids-util.el].
[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   (if (setq ret (char-ucs char))
55       (decode-char '=ucs ret)
56     char))
57
58 ;;;###autoload
59 (defun char-representative-of-domain (char domain)
60   "Convert CHAR into representative character of DOMAIN."
61   (let (ret)
62     (cond ((eq domain 'daikanwa)
63            (char-representative-of-daikanwa char))
64           ((eq domain 'ucs)
65            (char-representative-of-ucs char))
66           ((eq domain 'cns)
67            (if (setq ret (char-feature char '=>ucs@cns))
68                (decode-char '=ucs@cns ret)
69              (find-char-variant char 'char-cns11643-p)))
70           ((eq domain 'ks)
71            (if (setq ret (char-feature char '=>ucs@ks))
72                (decode-char '=ucs@ks ret)
73              (find-char-variant char 'char-ks-x1001-p)))
74           ((setq ret
75                  (or (char-feature char
76                                    (intern (format "=>ucs@%s" domain)))
77                      (char-ucs char)))
78            (decode-char (intern (format "=ucs@%s" domain)) ret))
79           (t char))))
80
81 ;;;###autoload
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)))
86              string ""))
87
88 ;;;###autoload
89 (defun ideo-translate-string-into-simplified-chinese (string)
90   "Simplify Chinese traditional characters in STRING."
91   (let (uchr ret)
92     (mapconcat
93      (lambda (chr)
94        (setq uchr
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)
101                       chr))
102                    (t chr)))
103        (char-to-string
104         (if (setq ret (encode-char uchr 'chinese-gb12345))
105             (decode-char 'chinese-gb2312 ret)
106           chr)))
107      string "")))
108
109 ;;;###autoload
110 (define-obsolete-function-alias 'ideo-trans-simplify-chinese-string
111   'ideo-translate-string-into-simplified-chinese)
112
113 ;;;###autoload
114 (defun ideo-translate-string-into-simplified-japanese (string)
115   "Simplify traditional Kanji characters in STRING."
116   (let (uchr ret)
117     (mapconcat
118      (lambda (chr)
119        (setq ret (or (char-feature chr '->simplified@JP/Jouyou)
120                      (char-feature chr '->simplified@JP)
121                      (char-feature chr '->simplified)))
122        (char-to-string
123         (cond ((car ret))
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))
128               (t chr))))
129      string "")))
130
131 ;;;###autoload
132 (defun ideo-translate-string-into-traditional (string)
133   "Convert simplified Kanji in STRING into traditional characters."
134   (let (uchr ret)
135     (mapconcat
136      (lambda (chr)
137        (char-to-string
138         (cond ((car (char-feature chr '<-simplified)))
139               ((progn
140                  (setq ret
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))
145                              (t chr)))
146                  (setq ret (or (char-feature ret '<-simplified@JP/Jouyou)
147                                (char-feature ret '<-simplified@JP))))
148                (car ret))
149               ((progn
150                  (setq ret
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))
155                              (t chr)))
156                  (if (setq ret (encode-char ret 'chinese-gb2312))
157                      (setq ret (decode-char 'chinese-gb12345 ret))))
158                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))
163               (t chr))))
164      string "")))
165
166 ;;;###autoload
167 (defun ideo-translate-region-into-traditional (start end)
168   (interactive "r")
169   (save-excursion
170     (save-restriction
171       (narrow-to-region start end)
172       (goto-char start)
173       (let (chr ret rret i prompt)
174         (while (and (skip-chars-forward "\x00-\xFF")
175                     (not (eobp)))
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)))
183               (progn
184                 (if (cdr ret)
185                     (progn
186                       (setq i 0)
187                       (setq prompt
188                             (concat
189                              (mapconcat (lambda (cell)
190                                           (setq i (1+ i))
191                                           (format "%d. %c" i cell))
192                                         ret " ")
193                              " : "))
194                       (while (and (setq rret
195                                         (string-to-int
196                                          (read-string prompt)))
197                                   (not (and (< 0 rret)
198                                             (<=  rret (length ret))))))
199                       (delete-char)
200                       (insert (nth (1- rret) ret)))
201                   (delete-char)
202                   (insert (car ret))))
203             (or (eobp)
204                 (forward-char))))))))
205
206
207 ;;; @ End.
208 ;;;
209
210 (provide 'ideo-trans)
211
212 ;;; ideo-trans.el ends here