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 ideo-translate-string-into-simplified-chinese (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 'ideo-trans-simplify-chinese-string
 112   'ideo-translate-string-into-simplified-chinese)
 113
 114 ;;;###autoload
 115 (defun ideo-translate-string-into-simplified-japanese (string)
 116   "Simplify traditional Kanji characters in STRING."
 117   (let (ret)
 118     (mapconcat
 119      (lambda (chr)
 120        (setq ret (or (char-feature chr '->simplified@JP/Jouyou)
 121                      (char-feature chr '->simplified@JP)
 122                      (char-feature chr '->simplified)))
 123        (char-to-string
 124         (cond ((car ret))
 125               ((setq ret (char-feature chr '=>ucs@jis))
 126                (decode-char '=ucs@jis ret))
 127               ((setq ret (char-ucs chr))
 128                (decode-char '=ucs@jp ret))
 129               (t chr))))
 130      string "")))
 131
 132 (defun ideo-trans-select-char (chars &optional prefix)
 133   (let ((i 0)
 134         prompt ret)
 135     (setq prompt
 136           (concat
 137            prefix
 138            (mapconcat (lambda (cell)
 139                         (setq i (1+ i))
 140                         (format "%d. %c" i cell))
 141                       chars " ")
 142            " : "))
 143     (while (and (setq ret (string-to-int (read-string prompt)))
 144                 (not (and (< 0 ret)
 145                           (<=  ret (length chars))))))
 146     (nth (1- ret) chars)))
 147
 148 ;;;###autoload
 149 (defun ideo-translate-chinese-string-into-traditional (string)
 150   "Convert simplified Chinese characters in STRING to traditional characters."
 151   (let (ret)
 152     (mapconcat
 153      (lambda (chr)
 154        (char-to-string
 155         (cond ((car (char-feature chr '<-simplified))
 156                (if (cdr ret)
 157                    (ideo-trans-select-char ret (format "%c => " chr))
 158                  (car ret)))
 159               ((progn
 160                  (setq ret
 161                        (cond ((setq ret (char-feature chr '=>ucs@gb))
 162                               (decode-char '=ucs@gb ret))
 163                              ((setq ret (char-ucs chr))
 164                               (decode-char '=ucs@gb ret))
 165                              (t chr)))
 166                  (if (setq ret (encode-char ret 'chinese-gb2312))
 167                      (setq ret (decode-char 'chinese-gb12345 ret))))
 168                ret)
 169               (t chr))))
 170      string "")))
 171
 172 ;;;###autoload
 173 (defun ideo-translate-japanese-string-into-traditional (string)
 174   "Convert simplified Kanji in STRING into traditional characters."
 175   (let (ret)
 176     (mapconcat
 177      (lambda (chr)
 178        (char-to-string
 179         (cond ((setq ret (char-feature chr '<-simplified))
 180                (if (cdr ret)
 181                    (ideo-trans-select-char ret (format "%c => " chr))
 182                  (car ret)))
 183               ((progn
 184                  (setq ret
 185                        (cond ((setq ret (char-feature chr '=>ucs@jis))
 186                               (decode-char '=ucs@jis ret))
 187                              ((setq ret (char-ucs chr))
 188                               (decode-char '=ucs@jp ret))
 189                              (t chr)))
 190                  (setq ret (or (char-feature ret '<-simplified@JP/Jouyou)
 191                                (char-feature ret '<-simplified@JP))))
 192                (if (cdr ret)
 193                    (ideo-trans-select-char ret (format "%c => " chr))
 194                  (car ret)))
 195               ((setq ret (char-feature chr '=>ucs@jis))
 196                (decode-char '=ucs@jis ret))
 197               ((setq ret (char-ucs chr))
 198                (decode-char '=ucs@jp ret))
 199               (t chr))))
 200      string "")))
 201
 202 ;;;###autoload
 203 (defun ideo-translate-japanese-region-into-traditional (start end)
 204   (interactive "r")
 205   (save-excursion
 206     (save-restriction
 207       (narrow-to-region start end)
 208       (goto-char start)
 209       (let (chr ret rret)
 210         (while (and (skip-chars-forward "\x00-\xFF")
 211                     (not (eobp)))
 212           (setq chr (char-after))
 213           (if (setq ret (or (get-char-attribute chr '<-simplified@JP/Jouyou)
 214                             (get-char-attribute chr '<-simplified@jp-jouyou)
 215                             (get-char-attribute chr '<-simplified@JP)
 216                             (get-char-attribute chr '<-simplified@jp)
 217                             (get-char-attribute chr '<-jp-simplified)
 218                             (get-char-attribute chr '<-simplified)))
 219               (progn
 220                 (if (cdr ret)
 221                     (progn
 222                       (setq rret (ideo-trans-select-char ret))
 223                       (delete-char)
 224                       (insert rret))
 225                   (delete-char)
 226                   (insert (car ret))))
 227             (or (eobp)
 228                 (forward-char))))))))
 229
 230 ;;;###autoload
 231 (define-obsolete-function-alias
 232   'ideo-translate-region-into-traditional
 233   'ideo-translate-japanese-region-into-traditional)
 234
 235
 236 ;;; @ End.
 237 ;;;
 238
 239 (provide 'ideo-trans)
 240
 241 ;;; ideo-trans.el ends here