idc-util.el

   1 ;;; idc-util.el --- Utilities about ideographic-structure property
   2
   3 ;; Copyright (C) 2001 MORIOKA Tomohiko
   4
   5 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
   6 ;; Keywords: ideographic-structure, UTF-2000, database
   7
   8 ;; This file is a part of Tomoyo Utilities.
   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 ;;; Commentary:
  26
  27 ;;; Code:
  28
  29 (defun ideographic-structure-convert-to-ucs (structure)
  30   (let (dest cell ucs ret)
  31     (while structure
  32       (setq cell (car structure))
  33       (setq dest
  34             (cons
  35              (cond ((characterp cell)
  36                     (if (or (get-char-attribute cell 'ucs)
  37                             (null
  38                              (setq ucs
  39                                    (or (get-char-attribute cell '=>ucs)
  40                                        (get-char-attribute cell '->ucs)))))
  41                         cell
  42                       (decode-char 'ucs ucs)))
  43                    ((and (consp cell)
  44                          (symbolp (car cell)))
  45                     cell)
  46                    ((setq ret (find-char cell))
  47                     (if (or (get-char-attribute ret 'ucs)
  48                             (null
  49                              (setq ucs
  50                                    (or (get-char-attribute ret '=>ucs)
  51                                        (get-char-attribute ret '->ucs)))))
  52                         cell
  53                       (decode-char 'ucs ucs)))
  54                    ((setq ret (assq 'ideographic-structure cell))
  55                     (put-alist 'ideographic-structure
  56                                (ideographic-structure-convert-to-ucs
  57                                 (cdr ret))
  58                                (copy-alist cell)))
  59                    (t cell))
  60              dest))
  61       (setq structure (cdr structure)))
  62     (nreverse dest)))
  63
  64 (defvar morohashi-char-replace-alist
  65   (list
  66    (cons (decode-char 'chinese-big5-cdp #x8B42)
  67          (decode-char 'chinese-big5-cdp #x8B42))
  68    (cons (decode-char 'chinese-big5-cdp #x8AFC)
  69          (decode-char 'chinese-big5-cdp #x8AFC))
  70    (cons (decode-char 'ucs #x2EBE)
  71          (decode-char 'ucs #x2EBF))
  72    (cons (decode-char 'ucs #x5922)
  73          (decode-char 'ideograph-daikanwa 05802))
  74    (cons (decode-char 'ucs #x656C)
  75          (decode-char 'ideograph-daikanwa 13303))
  76    (cons (decode-char 'ucs #x8449)
  77          (decode-char 'ideograph-daikanwa 31387))
  78    (cons (decode-char 'ucs #x2EA4)
  79          (decode-char 'ucs #x722B))
  80    (cons (decode-char 'ucs #x5151)
  81          (decode-char 'ideograph-daikanwa 01356))
  82    (cons (decode-char 'ucs #x544A)
  83          (decode-char 'ideograph-daikanwa 03381))
  84    (cons (decode-char 'ucs #x5F66)
  85          (decode-char 'ideograph-daikanwa 09980))
  86    (cons (decode-char 'ucs #x8005)
  87          (decode-char 'ideograph-daikanwa 28853))
  88    (cons (decode-char 'ucs #x82E5)
  89          (decode-char 'ideograph-daikanwa 30796))
  90    (cons (decode-char 'ucs #x82F1)
  91          (decode-char 'ideograph-daikanwa 30808))
  92    (cons (decode-char 'ucs #x9063)
  93          (decode-char 'ideograph-daikanwa 39052))
  94    (cons (decode-char 'ucs #x4EA0)
  95          (decode-char 'chinese-big5-cdp #x8B42))
  96    (cons (decode-char 'ucs #x5154)
  97          (decode-char 'ideograph-daikanwa 01368))
  98    (cons (decode-char 'ucs #x53CA)
  99          (decode-char 'ideograph-daikanwa 03118))
 100    (cons (decode-char 'ucs #x5468)
 101          (decode-char 'ideograph-daikanwa 03441))
 102    (cons (decode-char 'ucs #x5C1A)
 103          (decode-char 'ucs #x5C19))
 104    (cons (decode-char 'ucs #x5D29)
 105          (decode-char 'ideograph-daikanwa 08212))
 106    (cons (decode-char 'ucs #x670B)
 107          (decode-char 'ideograph-daikanwa 14340))
 108    (cons (decode-char 'ucs #x7FBD)
 109          (decode-char 'ideograph-daikanwa 28614))
 110    (cons (decode-char 'ucs #x8096)
 111          (decode-char 'ideograph-daikanwa 29263))
 112    (cons (decode-char 'ucs #x8981)
 113          (decode-char 'ideograph-daikanwa 34768))
 114    (cons (decode-char 'ucs #x8AF8)
 115          (decode-char 'ideograph-daikanwa 35743))
 116    (cons (decode-char 'ucs #x9023)
 117          (decode-char 'ideograph-daikanwa 38902))
 118    (cons (decode-char 'ucs #x9752)
 119          (decode-char 'ucs #x9751))
 120    ))
 121
 122 (defun ideographic-structure-convert-to-daikanwa (structure)
 123   (let (dest cell morohashi ret)
 124     (while structure
 125       (setq cell (car structure))
 126       (setq dest
 127             (cons
 128              (cond ((characterp cell)
 129                     (cond ((setq ret
 130                                  (assq cell morohashi-char-replace-alist))
 131                            (cdr ret))
 132                           ((get-char-attribute cell 'ideograph-daikanwa)
 133                            cell)
 134                           ((setq morohashi
 135                                  (get-char-attribute
 136                                   cell 'morohashi-daikanwa))
 137                            (cond ((null (cdr (cdr morohashi)))
 138                                   cell)
 139                                  ((= (nth 1 morohashi) 0)
 140                                   (decode-char 'ideograph-daikanwa
 141                                                (car morohashi)))
 142                                  (t
 143                                   (setq morohashi (list (car morohashi)
 144                                                         (nth 1 morohashi)))
 145                                   (or (map-char-attribute
 146                                        (lambda (char val)
 147                                          (if (equal morohashi val)
 148                                              char))
 149                                        'morohashi-daikanwa)
 150                                       cell))))
 151                           (t
 152                            cell)))
 153                    ((and (consp cell)
 154                          (symbolp (car cell)))
 155                     cell)
 156                    ((setq ret (find-char cell))
 157                     (if (or (get-char-attribute ret 'ideograph-daikanwa)
 158                             (null
 159                              (setq morohashi
 160                                    (get-char-attribute
 161                                     ret 'morohashi-daikanwa)))
 162                             (null (cdr (cdr morohashi))))
 163                         cell
 164                       (if (= (nth 1 morohashi) 0)
 165                           (decode-char 'ideograph-daikanwa (car morohashi))
 166                         cell)))
 167                    ((setq ret (assq 'ideographic-structure cell))
 168                     (put-alist 'ideographic-structure
 169                                (ideographic-structure-convert-to-daikanwa
 170                                 (cdr ret))
 171                                (copy-alist cell)))
 172                    (t cell))
 173              dest))
 174       (setq structure (cdr structure)))
 175     (nreverse dest)))
 176
 177
 178 ;;; @ End.
 179 ;;;
 180
 181 (provide 'idc-util)
 182
 183 ;;; idc-util.el ends here