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