ideo-trans.el

   1 ;;; ideo-trans.el --- Translation utility for Ideographic Strings
   2
   3 ;; Copyright (C) 2003,2004,2005,2008 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 (char-feature chr '=>ucs*))
 101                         (setq chr (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 uchr
 126              (cond ((setq ret (char-feature chr '=>ucs@jis))
 127                     (setq chr (decode-char '=ucs@jis ret)))
 128                    ((setq ret (char-ucs chr))
 129                     (setq chr (decode-char '=ucs@jis ret))
 130                     (if (setq ret (char-feature chr '=>ucs*))
 131                         (setq chr (decode-char '=ucs@jis ret))
 132                       chr))
 133                    (t chr)))
 134        (setq ret (or (char-feature chr '->simplified@JP/Jouyou)
 135                      (char-feature chr '->simplified@JP)
 136                      (char-feature chr '->simplified)))
 137        (char-to-string
 138         (cond ((car ret))
 139               ((setq ret (char-feature chr '=>ucs@jis))
 140                (decode-char '=ucs@jis ret))
 141               ((setq ret (char-ucs chr))
 142                (decode-char '=ucs@JP ret))
 143               (t chr))))
 144      string "")))
 145
 146 ;;;###autoload
 147 (define-obsolete-function-alias
 148   'ideo-translate-string-into-simplified-japanese
 149   'japanese-simplify-string)
 150
 151
 152 (defun ideo-trans-select-char (chars &optional prefix)
 153   (let ((i 0)
 154         prompt ret)
 155     (setq prompt
 156           (concat
 157            prefix
 158            (mapconcat (lambda (cell)
 159                         (setq i (1+ i))
 160                         (format "%d. %c" i cell))
 161                       chars " ")
 162            " : "))
 163     (while (and (setq ret (string-to-int (read-string prompt)))
 164                 (not (and (< 0 ret)
 165                           (<=  ret (length chars))))))
 166     (nth (1- ret) chars)))
 167
 168 ;;;###autoload
 169 (defun chinese-traditionalize-string (string &optional selector)
 170   "Convert simplified Chinese characters in STRING to traditional characters."
 171   (unless selector
 172     (setq selector
 173           (lambda (chars)
 174             (ideo-trans-select-char chars (format "%c => " chr)))))
 175   (let (ret)
 176     (mapconcat
 177      (lambda (chr)
 178        (char-to-string
 179         (cond ((car (char-feature chr '<-simplified))
 180                (if (cdr ret)
 181                    (funcall selector ret)
 182                  (car ret)))
 183               ((progn
 184                  (setq ret
 185                        (cond ((setq ret (char-feature chr '=>ucs@gb))
 186                               (decode-char '=ucs@gb ret))
 187                              ((setq ret (char-ucs chr))
 188                               (decode-char '=ucs@gb ret))
 189                              (t chr)))
 190                  (if (setq ret (encode-char ret 'chinese-gb2312))
 191                      (setq ret (decode-char 'chinese-gb12345 ret))))
 192                ret)
 193               (t chr))))
 194      string "")))
 195
 196 ;;;###autoload
 197 (define-obsolete-function-alias
 198   'ideo-translate-chinese-string-into-traditional
 199   'chinese-traditionalize-string)
 200
 201 ;;;###autoload
 202 (defun japanese-traditionalize-string (string &optional selector)
 203   "Convert simplified Kanji in STRING into traditional characters."
 204   (unless selector
 205     (setq selector
 206           (lambda (chars)
 207             (ideo-trans-select-char chars (format "%c => " chr)))))
 208   (let (ret)
 209     (mapconcat
 210      (lambda (chr)
 211        (char-to-string
 212         (cond ((setq ret (or (char-feature chr '<-simplified@JP/Jouyou)
 213                              (char-feature chr '<-simplified@JP)
 214                              (char-feature chr '<-simplified)))
 215                (if (cdr ret)
 216                    (funcall selector ret)
 217                  (car ret)))
 218               ((progn
 219                  (setq ret
 220                        (cond ((setq ret (char-feature chr '=>ucs@jis))
 221                               (decode-char '=ucs@jis ret))
 222                              ((setq ret (char-ucs chr))
 223                               (decode-char '=ucs@JP ret))
 224                              (t chr)))
 225                  (setq ret (or (char-feature ret '<-simplified@JP/Jouyou)
 226                                (char-feature ret '<-simplified@JP))))
 227                (if (cdr ret)
 228                    (ideo-trans-select-char ret (format "%c => " chr))
 229                  (car ret)))
 230               ((setq ret (char-feature chr '=>ucs@jis))
 231                (decode-char '=ucs@jis ret))
 232               ((setq ret (char-ucs chr))
 233                (decode-char '=ucs@JP ret))
 234               (t chr))))
 235      string "")))
 236
 237 ;;;###autoload
 238 (define-obsolete-function-alias
 239   'ideo-translate-japanese-string-into-traditional
 240   'japanese-traditionalize-string)
 241
 242 ;;;###autoload
 243 (defun japanese-traditionalize-region (start end)
 244   (interactive "r")
 245   (save-excursion
 246     (save-restriction
 247       (narrow-to-region start end)
 248       (goto-char start)
 249       (let (chr ret rret)
 250         (while (and (skip-chars-forward "\x00-\xFF")
 251                     (not (eobp)))
 252           (setq chr (char-after))
 253           (if (setq ret (or (char-feature chr '<-simplified@JP/Jouyou)
 254                             (char-feature chr '<-simplified@jp-jouyou)
 255                             (char-feature chr '<-simplified@JP)
 256                             (char-feature chr '<-simplified@jp)
 257                             (char-feature chr '<-jp-simplified)
 258                             (char-feature chr '<-simplified)))
 259               (progn
 260                 (if (cdr ret)
 261                     (progn
 262                       (setq rret (ideo-trans-select-char ret))
 263                       (delete-char)
 264                       (insert rret))
 265                   (delete-char)
 266                   (insert (car ret))))
 267             (or (eobp)
 268                 (forward-char))))))))
 269
 270 ;;;###autoload
 271 (defun japanese-simplify-region (start end)
 272   (interactive "r")
 273   (save-excursion
 274     (save-restriction
 275       (narrow-to-region start end)
 276       (goto-char start)
 277       (let (chr ret rret)
 278         (while (and (skip-chars-forward "\x00-\xFF")
 279                     (not (eobp)))
 280           (setq chr (char-after))
 281           (if (setq ret (or (char-feature chr '->simplified@JP/Jouyou)
 282                             (char-feature chr '->simplified@jp-jouyou)
 283                             (char-feature chr '->simplified@JP)
 284                             (char-feature chr '->simplified@jp)
 285                             (char-feature chr '->jp-simplified)
 286                             (char-feature chr '->simplified)))
 287               (progn
 288                 (if (cdr ret)
 289                     (progn
 290                       (setq rret (ideo-trans-select-char ret))
 291                       (delete-char)
 292                       (insert rret))
 293                   (delete-char)
 294                   (insert (car ret))))
 295             (or (eobp)
 296                 (forward-char))))))))
 297
 298 ;;;###autoload
 299 (define-obsolete-function-alias
 300   'ideo-translate-japanese-region-into-traditional
 301   'japanese-traditionalize-region)
 302
 303 ;;;###autoload
 304 (define-obsolete-function-alias
 305   'ideo-translate-region-into-traditional
 306   'japanese-traditionalize-region)
 307
 308
 309 ;;; @ End.
 310 ;;;
 311
 312 (provide 'ideo-trans)
 313
 314 ;;; ideo-trans.el ends here