ids-util.el

   1 ;;; ids-util.el --- Utilities about ideographic-structure -*- coding: utf-8 -*-
   2
   3 ;; Copyright (C) 2001,2002,2003,2004 MORIOKA Tomohiko
   4
   5 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
   6 ;; Keywords: ideographic-structure, CHISE, IDS, IDC, UCS, 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 ;;;###autoload
  30 (defun ideographic-structure-convert-to-domain (structure domain)
  31   (let (dest cell ret)
  32     (while structure
  33       (setq cell (car structure))
  34       (setq dest
  35             (cons
  36              (cond ((characterp cell)
  37                     (char-representative-of-domain cell domain))
  38                    ((and (consp cell)
  39                          (symbolp (car cell)))
  40                     cell)
  41                    ((setq ret (find-char cell))
  42                     (char-representative-of-domain cell domain))
  43                    ((setq ret (assq 'ideographic-structure cell))
  44                     (put-alist 'ideographic-structure
  45                                (ideographic-structure-convert-to-domain
  46                                 (cdr ret) domain)
  47                                (copy-alist cell)))
  48                    (t cell))
  49              dest))
  50       (setq structure (cdr structure)))
  51     (nreverse dest)))
  52
  53 ;;;###autoload
  54 (defun ideographic-structure-convert-to-ucs (structure)
  55   (let (dest cell ucs ret)
  56     (while structure
  57       (setq cell (car structure))
  58       (setq dest
  59             (cons
  60              (cond ((characterp cell)
  61                     (if (or (get-char-attribute cell 'ucs)
  62                             (null
  63                              (setq ucs
  64                                    (or (get-char-attribute cell '=>ucs)
  65                                        (get-char-attribute cell '->ucs)))))
  66                         cell
  67                       (decode-char 'ucs ucs)))
  68                    ((and (consp cell)
  69                          (symbolp (car cell)))
  70                     cell)
  71                    ((setq ret (find-char cell))
  72                     (if (or (get-char-attribute ret 'ucs)
  73                             (null
  74                              (setq ucs
  75                                    (or (get-char-attribute ret '=>ucs)
  76                                        (get-char-attribute ret '->ucs)))))
  77                         cell
  78                       (decode-char 'ucs ucs)))
  79                    ((setq ret (assq 'ideographic-structure cell))
  80                     (put-alist 'ideographic-structure
  81                                (ideographic-structure-convert-to-ucs
  82                                 (cdr ret))
  83                                (copy-alist cell)))
  84                    (t cell))
  85              dest))
  86       (setq structure (cdr structure)))
  87     (nreverse dest)))
  88
  89 (defun char-cns11643-p (char &optional defined-only)
  90   (some (lambda (n)
  91           (encode-char char
  92                        (intern (format "=cns11643-%d" n))
  93                        defined-only))
  94         '(1 2 3 4 5 6 7)))
  95
  96 (defun char-representative-of-cns11643 (char)
  97   (if (char-cns11643-p char)
  98       char
  99     (let ((ucs (char-ucs char))
 100           variants)
 101       (if (and ucs
 102                (setq variants
 103                      (char-variants (decode-char 'ucs ucs))))
 104           (while (and variants
 105                       (setq char (car variants))
 106                       (not (char-cns11643-p char)))
 107             (setq variants (cdr variants))))
 108       char)))
 109
 110 (defun ideographic-structure-convert-to-cns11643 (structure)
 111   (let (dest cell ucs ret)
 112     (while structure
 113       (setq cell (car structure))
 114       (setq dest
 115             (cons
 116              (cond ((characterp cell)
 117                     (char-representative-of-cns11643 cell))
 118                    ((and (consp cell)
 119                          (symbolp (car cell)))
 120                     cell)
 121                    ((setq ret (find-char cell))
 122                     (char-representative-of-cns11643 ret))
 123                    ((setq ret (assq 'ideographic-structure cell))
 124                     (put-alist 'ideographic-structure
 125                                (ideographic-structure-convert-to-cns11643
 126                                 (cdr ret))
 127                                (copy-alist cell)))
 128                    (t cell))
 129              dest))
 130       (setq structure (cdr structure)))
 131     (nreverse dest)))
 132
 133 (defvar morohashi-char-replace-alist
 134   (list
 135    (cons (decode-char 'chinese-big5-cdp #x8B42)
 136          (decode-char 'chinese-big5-cdp #x8B42))
 137    (cons (decode-char 'chinese-big5-cdp #x8AFC)
 138          (decode-char 'chinese-big5-cdp #x8AFC))
 139    (cons (decode-char 'ucs #x2EBE)
 140          (decode-char 'ucs #x2EBF))
 141    (cons (decode-char 'ucs #x4EA0)
 142          (decode-char 'chinese-big5-cdp #x8B42))
 143    (cons (decode-char 'ucs #x4EBD)
 144          (decode-char 'chinese-big5-cdp #x8AFC))
 145    (cons (decode-char 'ucs #x517C)
 146          (decode-char 'ideograph-gt 01936))
 147    (cons ?亼 (decode-char 'chinese-big5-cdp #x8AFC))
 148    (cons (decode-char 'chinese-big5-cdp #x8AFC)
 149          (decode-char 'chinese-big5-cdp #x8AFC))
 150    (cons (decode-char 'chinese-big5-cdp #x8B69)
 151          (decode-char 'chinese-big5-cdp #x8A60))
 152    (cons (decode-char 'ucs #x4FDE)
 153          (decode-char 'ideograph-daikanwa 01437))
 154    (cons (decode-char 'ucs #x5151)
 155          (decode-char 'ideograph-daikanwa 01356))
 156    (cons (decode-char 'ucs #x5154)
 157          (decode-char 'ideograph-daikanwa 01368))
 158    (cons (decode-char 'ucs #x5179)
 159          (decode-char 'ideograph-daikanwa 30911))
 160    (cons (decode-char 'ucs #x518D)
 161          (decode-char 'ideograph-daikanwa 01524))
 162    (cons (decode-char 'ucs #x5193)
 163          (decode-char 'ideograph-gt 02025))
 164    (cons (decode-char 'ucs #x53CA)
 165          (decode-char 'ideograph-daikanwa 03118))
 166    (cons (decode-char 'ucs #x544A)
 167          (decode-char 'ideograph-daikanwa 03381))
 168    (cons (decode-char 'ucs #x5468)
 169          (decode-char 'ideograph-daikanwa 03441))
 170    '(?夂 . ?夂)
 171    (cons (decode-char 'ucs #x5922)
 172          (decode-char 'ideograph-daikanwa 05802))
 173    (cons (decode-char 'ucs #x5C1A)
 174          (decode-char 'ucs #x5C19))
 175    (cons (decode-char 'ucs #x5D29)
 176          (decode-char 'ideograph-daikanwa 08212))
 177    (cons (decode-char 'ucs #x5F66)
 178          (decode-char 'ideograph-daikanwa 09980))
 179    (cons (decode-char 'ucs #x6247)
 180          (decode-char 'ideograph-daikanwa 11743))
 181    (cons (decode-char 'ucs #x656C)
 182          (decode-char 'ideograph-daikanwa 13303))
 183    (cons (decode-char 'ucs #x65E2)
 184          (decode-char 'ideograph-daikanwa 13724))
 185    (cons (decode-char 'ucs #x6B21)
 186          (decode-char 'ideograph-daikanwa 15992))
 187    (cons (decode-char 'ucs #x7235)
 188          (decode-char 'ideograph-daikanwa 19711))
 189    (cons (decode-char 'ucs #x7523)
 190          (decode-char 'ideograph-daikanwa 21684))
 191    (cons (decode-char 'ucs #x76CA)
 192          (decode-char 'ideograph-daikanwa 22972))
 193    (cons (decode-char 'ucs #x771F)
 194          (decode-char 'ideograph-daikanwa 23235))
 195    (cons (decode-char 'ucs #x7FBD)
 196          (decode-char 'ideograph-daikanwa 28614))
 197    (cons (decode-char 'ucs #x7FC1)
 198          (decode-char 'ideograph-daikanwa 28635))
 199    (cons (decode-char 'ucs #x2EA4)
 200          (decode-char 'ucs #x722B))
 201    (cons (decode-char 'ucs #x8005)
 202          (decode-char 'ideograph-daikanwa 28853))
 203    (cons (decode-char 'ucs #x8096)
 204          (decode-char 'ideograph-daikanwa 29263))
 205    (cons (decode-char 'ucs #x82E5)
 206          (decode-char 'ideograph-daikanwa 30796))
 207    (cons (decode-char 'ucs #x82D7)
 208          (decode-char 'ideograph-daikanwa 30781))
 209    (cons (decode-char 'ucs #x82F1)
 210          (decode-char 'ideograph-daikanwa 30808))
 211    (cons (decode-char 'ucs #x8336)
 212          (decode-char 'ideograph-daikanwa 30915))
 213    (cons (decode-char 'ucs #x8449)
 214          (decode-char 'ideograph-daikanwa 31387))
 215    (cons (decode-char 'ucs #x9023)
 216          (decode-char 'ideograph-daikanwa 38902))
 217    (cons (decode-char 'ucs #x9053)
 218          (decode-char 'ideograph-daikanwa 39010))
 219    (cons (decode-char 'ucs #x9054)
 220          (decode-char 'ideograph-daikanwa 39011))
 221    (cons (decode-char 'ucs #x9063)
 222          (decode-char 'ideograph-daikanwa 39052))
 223    (cons (decode-char 'ucs #x9752)
 224          (decode-char 'ucs #x9751))
 225    (cons (decode-char 'ucs #x670B)
 226          (decode-char 'ideograph-daikanwa 14340))
 227    (cons (decode-char 'ucs #x8981)
 228          (decode-char 'ideograph-daikanwa 34768))
 229    (cons (decode-char 'ucs #x8AF8)
 230          (decode-char 'ideograph-daikanwa 35743))
 231    (cons (decode-char 'japanese-jisx0213-2 #x2327)
 232          (decode-char 'japanese-jisx0213-2 #x2327))
 233    (cons (decode-char 'chinese-big5-cdp #x8BFA)
 234          (decode-char 'japanese-jisx0213-2 #x2327))
 235    ))
 236
 237 ;;;###autoload
 238 (defun ideographic-structure-convert-to-daikanwa (structure)
 239   (let (dest cell morohashi ret ret2 ret3)
 240     (while structure
 241       (setq cell (car structure))
 242       (setq dest
 243             (cons
 244              (cond ((characterp cell)
 245                     (cond ((setq ret
 246                                  (assq cell morohashi-char-replace-alist))
 247                            (cdr ret))
 248                           ((get-char-attribute cell 'ideograph-daikanwa)
 249                            cell)
 250                           ((setq morohashi
 251                                  (get-char-attribute
 252                                   cell 'morohashi-daikanwa))
 253                            (cond ((null (cdr (cdr morohashi)))
 254                                   cell)
 255                                  ((= (nth 1 morohashi) 0)
 256                                   (decode-char 'ideograph-daikanwa
 257                                                (car morohashi)))
 258                                  (t
 259                                   (setq morohashi (list (car morohashi)
 260                                                         (nth 1 morohashi)))
 261                                   (or (map-char-attribute
 262                                        (lambda (char val)
 263                                          (if (equal morohashi val)
 264                                              char))
 265                                        'morohashi-daikanwa)
 266                                       cell))))
 267                           (t
 268                            cell)))
 269                    ((and (consp cell)
 270                          (symbolp (car cell)))
 271                     cell)
 272                    ((setq ret (find-char cell))
 273                     (if (or (get-char-attribute ret 'ideograph-daikanwa)
 274                             (null
 275                              (setq morohashi
 276                                    (get-char-attribute
 277                                     ret 'morohashi-daikanwa)))
 278                             (null (cdr (cdr morohashi))))
 279                         cell
 280                       (if (= (nth 1 morohashi) 0)
 281                           (decode-char 'ideograph-daikanwa (car morohashi))
 282                         cell)))
 283                    ((setq ret (assq 'ideographic-structure cell))
 284                     (setq ret2
 285                           (ideographic-structure-convert-to-daikanwa
 286                            (cdr ret)))
 287                     (if (setq ret3 (ideographic-structure-find-char ret2))
 288                         ret3
 289                       (put-alist 'ideographic-structure
 290                                  ret2
 291                                  (copy-alist cell))))
 292                    (t cell))
 293              dest))
 294       (setq structure (cdr structure)))
 295     (nreverse dest)))
 296
 297
 298 ;;; @ End.
 299 ;;;
 300
 301 (provide 'ids-util)
 302
 303 ;;; ids-util.el ends here