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 ;;;###autoload
  77 (defun char-ideographic-radical (char &optional radical ignore-sisters)
  78   (let (ret)
  79     (or (if radical
  80             (get-char-feature-from-domains
  81              char 'ideographic-radical (cons nil char-db-feature-domains)
  82              'ideographic-radical radical ignore-sisters)
  83           (get-char-feature-from-domains
  84            char 'ideographic-radical (cons nil char-db-feature-domains)
  85            ignore-sisters))
  86         ;; (catch 'tag
  87         ;;   (dolist (domain char-db-feature-domains)
  88         ;;     (if (and (setq ret (char-feature
  89         ;;                         char
  90         ;;                         (intern
  91         ;;                          (format "%s@%s"
  92         ;;                                  'ideographic-radical domain))))
  93         ;;              (or (eq ret radical)
  94         ;;                  (null radical)))
  95         ;;         (throw 'tag ret))))
  96         (catch 'tag
  97           (dolist (cell (get-char-attribute char 'ideographic-))
  98             (if (and (setq ret (plist-get cell :radical))
  99                      (or (eq ret radical)
 100                          (null radical)))
 101                 (throw 'tag ret))))
 102         (get-char-feature-from-domains
 103          char 'ideographic-radical (cons nil char-db-feature-domains))
 104         ;; (char-feature char 'ideographic-radical)
 105         (progn
 106           (setq ret
 107                 (or (get-char-attribute char 'daikanwa-radical)
 108                     (get-char-attribute char 'kangxi-radical)
 109                     (get-char-attribute char 'japanese-radical)
 110                     (get-char-attribute char 'korean-radical)))
 111           (when ret
 112             (put-char-attribute char 'ideographic-radical ret)
 113             ret)))))
 114
 115
 116 ;;; @@ strokes of non-radical parts
 117 ;;;
 118
 119 ;;;###autoload
 120 (defun char-ideographic-strokes-from-domains (char domains &optional radical)
 121   (if radical
 122       (get-char-feature-from-domains char 'ideographic-strokes domains
 123                                      'ideographic-radical radical)
 124     (get-char-feature-from-domains char 'ideographic-strokes domains)))
 125
 126 (defvar ideograph-radical-strokes-vector
 127   ;;0  1  2  3  4  5  6  7  8  9
 128   [nil 1  1  1  1  1  1  2  2  2
 129     2  2  2  2  2  2  2  2  2  2
 130     2  2  2  2  2  2  2  2  2  2
 131     3  3  3  3  3  3  3  3  3  3
 132     3  3  3  3  3  3  3  3  3  3
 133     3  3  3  3  3  3  3  3  3  3
 134     3  4  4  4  3  4  4  4  4  4
 135     4  4  4  4  4  4  4  4  4  4
 136     4  4  4  4  4  3  4  4  4  4
 137     4  4  4  4  3  5  4  5  5  5
 138     ;; 100
 139     5  5  5  5  5  5  5  5  5  5
 140     5  5  5  5  5  5  5  5  6  6
 141     6  6  6  6  6  6  6  6  6  6
 142     4  6  6  6  6  6  6  6  6  6
 143     4  6  6  6  6  6  6  7  7  7
 144     7  7  7  7  7  7  7  7  7  7
 145     7  7  4  3  7  7  7  8  7  8
 146     3  8  8  8  8  8  9  9  9  9
 147     9  9  9  9  8  9  9 10 10 10
 148    10 10 10 10 10 11 11 11 11 11
 149    ;; 200
 150    11 12 12 12 12 13 13 13 13 14
 151    14 15 16 16 17])
 152
 153 ;;;###autoload
 154 (defun char-ideographic-strokes (char &optional radical preferred-domains)
 155   (let (ret)
 156     (or (catch 'tag
 157           (dolist (cell (get-char-attribute char 'ideographic-))
 158             (if (and (setq ret (plist-get cell :radical))
 159                      (or (eq ret radical)
 160                          (null radical)))
 161                 (throw 'tag (plist-get cell :strokes)))))
 162         (char-ideographic-strokes-from-domains
 163          char (append preferred-domains
 164                       (cons nil
 165                             char-db-feature-domains))
 166          radical)
 167         (get-char-attribute char 'daikanwa-strokes)
 168         (let ((strokes
 169                (or (get-char-attribute char 'kangxi-strokes)
 170                    (get-char-attribute char 'japanese-strokes)
 171                    (get-char-attribute char 'korean-strokes)
 172                    (let ((r (char-ideographic-radical char))
 173                          (ts (get-char-attribute char 'total-strokes)))
 174                      (if (and r ts)
 175                          (- ts (aref ideograph-radical-strokes-vector r))))
 176                    )))
 177           (when strokes
 178             (put-char-attribute char 'ideographic-strokes strokes)
 179             strokes)))))
 180
 181
 182 ;;; @@ total-strokes
 183 ;;;
 184
 185 ;;;###autoload
 186 (defun char-total-strokes-from-domains (char domains)
 187   (let (ret)
 188     (catch 'tag
 189       (dolist (domain domains)
 190         (if (setq ret (char-feature
 191                        char
 192                        (intern
 193                         (format "%s@%s"
 194                                 'total-strokes domain))))
 195             (throw 'tag ret))))))
 196
 197 ;;;###autoload
 198 (defun char-total-strokes (char &optional preferred-domains)
 199   (or (char-total-strokes-from-domains char preferred-domains)
 200       (char-feature char 'total-strokes)
 201       (char-total-strokes-from-domains char char-db-feature-domains)))
 202
 203
 204 ;;; @ end
 205 ;;;
 206
 207 (provide 'ideograph-subr)
 208
 209 ;;; ideograph-subr.el ends here