ideo-trans.el

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