git.chise.org Git - chise/xemacs-chise.git.1/blob - lisp/utf-2000/ideograph-subr.el

   1 ;;; ideograph-subr.el --- basic lisp subroutines about Ideographs -*- coding: utf-8-er; -*-
   2
   3 ;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2010
   4 ;;   MORIOKA Tomohiko.
   5
   6 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
   7 ;; Keywords: CHISE, Character Database, ISO/IEC 10646, UCS, Unicode, MULE.
   8
   9 ;; This file is part of XEmacs CHISE.
  10
  11 ;; XEmacs CHISE is free software; you can redistribute it and/or
  12 ;; modify it under the terms of the GNU General Public License as
  13 ;; published by the Free Software Foundation; either version 2, or (at
  14 ;; your option) any later version.
  15
  16 ;; XEmacs CHISE is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with XEmacs CHISE; see the file COPYING.  If not, write to
  23 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Code:
  27
  28 (require 'chise-subr)
  29
  30
  31 ;;; @ radical code
  32 ;;;
  33
  34 (defconst ideographic-radicals
  35   (let ((v (make-vector 215 nil))
  36         (i 1))
  37     (while (< i 215)
  38       (aset v i (decode-char '=ucs (+ #x2EFF i)))
  39       (setq i (1+ i)))
  40     v))
  41
  42 ;;;###autoload
  43 (defun ideographic-radical (number)
  44   "Return character corresponding with Kangxi-radical number."
  45   (aref ideographic-radicals number))
  46
  47
  48 ;;; @ char feature
  49 ;;;
  50
  51 (defun get-char-feature-from-domains (char feature domains
  52                                            &optional tester arg
  53                                            ignore-sisters)
  54   (map-char-family
  55    (lambda (ch)
  56      (let (ret)
  57        (catch 'tag
  58          (dolist (domain domains)
  59            (if (and (or (null tester)
  60                         (equal (or (char-feature
  61                                     ch (expand-char-feature-name
  62                                         tester domain))
  63                                    (char-feature ch tester))
  64                                arg))
  65                     (setq ret (or (char-feature
  66                                    ch (expand-char-feature-name
  67                                        feature domain))
  68                                   (char-feature ch feature))))
  69                (throw 'tag ret))))))
  70    char ignore-sisters))
  71
  72
  73 ;;; @@ radical
  74 ;;;
  75
  76 (defun char-ideographic-radical (char &optional radical ignore-sisters)
  77   (let (ret)
  78     (or (if radical
  79             (get-char-feature-from-domains
  80              char 'ideographic-radical (cons nil char-db-feature-domains)
  81              'ideographic-radical radical ignore-sisters)
  82           (get-char-feature-from-domains
  83            char 'ideographic-radical (cons nil char-db-feature-domains)
  84            ignore-sisters))
  85         ;; (catch 'tag
  86         ;;   (dolist (domain char-db-feature-domains)
  87         ;;     (if (and (setq ret (char-feature
  88         ;;                         char
  89         ;;                         (intern
  90         ;;                          (format "%s@%s"
  91         ;;                                  'ideographic-radical domain))))
  92         ;;              (or (eq ret radical)
  93         ;;                  (null radical)))
  94         ;;         (throw 'tag ret))))
  95         (catch 'tag
  96           (dolist (cell (get-char-attribute char 'ideographic-))
  97             (if (and (setq ret (plist-get cell :radical))
  98                      (or (eq ret radical)
  99                          (null radical)))
 100                 (throw 'tag ret))))
 101         (get-char-feature-from-domains
 102          char 'ideographic-radical (cons nil char-db-feature-domains))
 103         ;; (char-feature char 'ideographic-radical)
 104         (progn
 105           (setq ret
 106                 (or (get-char-attribute char 'daikanwa-radical)
 107                     (get-char-attribute char 'kangxi-radical)
 108                     (get-char-attribute char 'japanese-radical)
 109                     (get-char-attribute char 'korean-radical)))
 110           (when ret
 111             (put-char-attribute char 'ideographic-radical ret)
 112             ret)))))
 113
 114
 115 ;;; @@ strokes of non-radical parts
 116 ;;;
 117
 118 ;;;###autoload
 119 (defun char-ideographic-strokes-from-domains (char domains &optional radical)
 120   (if radical
 121       (get-char-feature-from-domains char 'ideographic-strokes domains
 122                                      'ideographic-radical radical)
 123     (get-char-feature-from-domains char 'ideographic-strokes domains)))
 124
 125 (defvar ideograph-radical-strokes-vector
 126   ;;0  1  2  3  4  5  6  7  8  9
 127   [nil 1  1  1  1  1  1  2  2  2
 128     2  2  2  2  2  2  2  2  2  2
 129     2  2  2  2  2  2  2  2  2  2
 130     3  3  3  3  3  3  3  3  3  3
 131     3  3  3  3  3  3  3  3  3  3
 132     3  3  3  3  3  3  3  3  3  3
 133     3  4  4  4  3  4  4  4  4  4
 134     4  4  4  4  4  4  4  4  4  4
 135     4  4  4  4  4  3  4  4  4  4
 136     4  4  4  4  3  5  4  5  5  5
 137     ;; 100
 138     5  5  5  5  5  5  5  5  5  5
 139     5  5  5  5  5  5  5  5  6  6
 140     6  6  6  6  6  6  6  6  6  6
 141     4  6  6  6  6  6  6  6  6  6
 142     4  6  6  6  6  6  6  7  7  7
 143     7  7  7  7  7  7  7  7  7  7
 144     7  7  4  3  7  7  7  8  7  8
 145     3  8  8  8  8  8  9  9  9  9
 146     9  9  9  9  8  9  9 10 10 10
 147    10 10 10 10 10 11 11 11 11 11
 148    ;; 200
 149    11 12 12 12 12 13 13 13 13 14
 150    14 15 16 16 17])
 151
 152 ;;;###autoload
 153 (defun char-ideographic-strokes (char &optional radical preferred-domains)
 154   (let (ret)
 155     (or (catch 'tag
 156           (dolist (cell (get-char-attribute char 'ideographic-))
 157             (if (and (setq ret (plist-get cell :radical))
 158                      (or (eq ret radical)
 159                          (null radical)))
 160                 (throw 'tag (plist-get cell :strokes)))))
 161         (char-ideographic-strokes-from-domains
 162          char (append preferred-domains
 163                       (cons nil
 164                             char-db-feature-domains))
 165          radical)
 166         (get-char-attribute char 'daikanwa-strokes)
 167         (let ((strokes
 168                (or (get-char-attribute char 'kangxi-strokes)
 169                    (get-char-attribute char 'japanese-strokes)
 170                    (get-char-attribute char 'korean-strokes)
 171                    (let ((r (char-ideographic-radical char))
 172                          (ts (get-char-attribute char 'total-strokes)))
 173                      (if (and r ts)
 174                          (- ts (aref ideograph-radical-strokes-vector r))))
 175                    )))
 176           (when strokes
 177             (put-char-attribute char 'ideographic-strokes strokes)
 178             strokes)))))
 179
 180
 181 ;;; @@ total-strokes
 182 ;;;
 183
 184 ;;;###autoload
 185 (defun char-total-strokes-from-domains (char domains)
 186   (let (ret)
 187     (catch 'tag
 188       (dolist (domain domains)
 189         (if (setq ret (char-feature
 190                        char
 191                        (intern
 192                         (format "%s@%s"
 193                                 'total-strokes domain))))
 194             (throw 'tag ret))))))
 195
 196 ;;;###autoload
 197 (defun char-total-strokes (char &optional preferred-domains)
 198   (or (char-total-strokes-from-domains char preferred-domains)
 199       (char-feature char 'total-strokes)
 200       (char-total-strokes-from-domains char char-db-feature-domains)))
 201
 202
 203 ;;; @ end
 204 ;;;
 205
 206 (provide 'ideograph-subr)
 207
 208 ;;; ideograph-subr.el ends here