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 (define-obsolete-function-alias
 253   'ideo-translate-japanese-region-into-traditional
 254   'japanese-traditionalize-region)
 255
 256 ;;;###autoload
 257 (define-obsolete-function-alias
 258   'ideo-translate-region-into-traditional
 259   'japanese-traditionalize-region)
 260
 261
 262 ;;; @ End.
 263 ;;;
 264
 265 (provide 'ideo-trans)
 266
 267 ;;; ideo-trans.el ends here