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) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
   4 ;;   2007, 2008, 2009, 2010 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 ;;; @ radical code
  29 ;;;
  30
  31 (defconst ideographic-radicals
  32   (let ((v (make-vector 215 nil))
  33         (i 1))
  34     (while (< i 215)
  35       (aset v i (decode-char '=ucs (+ #x2EFF i)))
  36       (setq i (1+ i)))
  37     v))
  38
  39 ;;;###autoload
  40 (defun ideographic-radical (number)
  41   "Return character corresponding with Kangxi-radical number."
  42   (aref ideographic-radicals number))
  43
  44
  45 ;;; @ char feature
  46 ;;;
  47
  48 (defun get-char-feature-from-domains (char feature domains
  49                                            &optional tester arg
  50                                            ignore-sisters)
  51   (map-char-family
  52    (lambda (ch)
  53      (let (ret)
  54        (catch 'tag
  55          (dolist (domain domains)
  56            (if (and (or (null tester)
  57                         (equal (or (char-feature
  58                                     ch (expand-char-feature-name
  59                                         tester domain))
  60                                    (char-feature ch tester))
  61                                arg))
  62                     (setq ret (or (char-feature
  63                                    ch (expand-char-feature-name
  64                                        feature domain))
  65                                   (char-feature ch feature))))
  66                (throw 'tag ret))))))
  67    char ignore-sisters))
  68
  69
  70 (defun char-ideographic-radical (char &optional radical ignore-sisters)
  71   (let (ret)
  72     (or (if radical
  73             (get-char-feature-from-domains
  74              char 'ideographic-radical (cons nil char-db-feature-domains)
  75              'ideographic-radical radical ignore-sisters)
  76           (get-char-feature-from-domains
  77            char 'ideographic-radical (cons nil char-db-feature-domains)
  78            ignore-sisters))
  79         ;; (catch 'tag
  80         ;;   (dolist (domain char-db-feature-domains)
  81         ;;     (if (and (setq ret (char-feature
  82         ;;                         char
  83         ;;                         (intern
  84         ;;                          (format "%s@%s"
  85         ;;                                  'ideographic-radical domain))))
  86         ;;              (or (eq ret radical)
  87         ;;                  (null radical)))
  88         ;;         (throw 'tag ret))))
  89         (catch 'tag
  90           (dolist (cell (get-char-attribute char 'ideographic-))
  91             (if (and (setq ret (plist-get cell :radical))
  92                      (or (eq ret radical)
  93                          (null radical)))
  94                 (throw 'tag ret))))
  95         (get-char-feature-from-domains
  96          char 'ideographic-radical (cons nil char-db-feature-domains))
  97         ;; (char-feature char 'ideographic-radical)
  98         (progn
  99           (setq ret
 100                 (or (get-char-attribute char 'daikanwa-radical)
 101                     (get-char-attribute char 'kangxi-radical)
 102                     (get-char-attribute char 'japanese-radical)
 103                     (get-char-attribute char 'korean-radical)))
 104           (when ret
 105             (put-char-attribute char 'ideographic-radical ret)
 106             ret)))))
 107
 108
 109 ;;;###autoload
 110 (defun char-ideographic-strokes-from-domains (char domains &optional radical)
 111   (if radical
 112       (get-char-feature-from-domains char 'ideographic-strokes domains
 113                                      'ideographic-radical radical)
 114     (get-char-feature-from-domains char 'ideographic-strokes domains)))
 115
 116
 117
 118 ;;; @ end
 119 ;;;
 120
 121 (provide 'ideograph-subr)
 122
 123 ;;; ideograph-subr.el ends here