conv-util.el

   1 ;;; conv-util.el --- Dump utility of mapping tables
   2
   3 ;; Copyright (C) 2004 MORIOKA Tomohiko
   4
   5 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
   6 ;; Keywords: Ideographs, Character Database, CHISE, UCS, Unicode
   7
   8 ;; This file is a part of tomoyo-tools.
   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 ;;; Code:
  26
  27 (require 'ideograph-util)
  28
  29
  30 (defun conv-u-convert-char (c &optional v)
  31   (setq v (get-char-attribute c '->ucs-unified))
  32   (let (ufs ifs ucs m ret)
  33     (when (or (and
  34                (setq m (get-char-attribute c 'morohashi-daikanwa))
  35                (setq m (if (eq (nth 1 m) 0)
  36                            (car m)
  37                          (list (car m)(nth 1 m)))))
  38               (setq m (encode-char c '=daikanwa 'defined-only)))
  39       (setq ufs (char-attribute-alist c)
  40             ifs ufs)
  41       (dolist (vc v)
  42         (setq ifs (intersection
  43                    ifs
  44                    (char-attribute-alist vc)
  45                    :test #'equal)))
  46       (if (setq ucs (encode-char c '=ucs 'defined-only))
  47           (progn
  48             (remove-char-attribute c '=ucs)
  49             (if (<= ucs #xFFFF)
  50                 (put-char-attribute c '=ucs@unicode ucs)
  51               (put-char-attribute c '=ucs@iso ucs))
  52             (remove-char-attribute c '->ucs-unified))
  53         (setq ucs (char-ucs c)))
  54       (setq v (sort (cons c v)
  55                     (function ideograph-char<)))
  56       (setq ret (define-char
  57                   (cons (cons '->subsumptive v)
  58                         ifs)))
  59       (put-char-attribute ret '=ucs ucs)
  60       (dolist (vc v)
  61         (dolist (isf ifs)
  62           (remove-char-attribute vc (car isf)))
  63         (when (and (setq m (get-char-attribute vc 'morohashi-daikanwa))
  64                    (or (eq (nth 1 m) 0)
  65                        (nth 2 m)))
  66           (remove-char-attribute vc 'morohashi-daikanwa))
  67         (if (eq ucs (get-char-attribute vc '=>ucs))
  68             (remove-char-attribute vc '=>ucs)))
  69       )))
  70
  71 (defun conv-u-convert-char-fullwidth (c &optional v)
  72   (when (setq v (get-char-attribute c '->ucs-unified))
  73     (let (ufs ifs ucs name ret)
  74       (when (get-char-attribute c '->fullwidth)
  75         (setq ufs (char-attribute-alist c)
  76               ifs ufs)
  77         (dolist (vc v)
  78           (setq ifs (intersection
  79                      ifs
  80                      (char-attribute-alist vc)
  81                      :test #'equal)))
  82         (dolist (cell ufs)
  83           (cond ((eq (car cell) 'name)
  84                  (setq name (cdr cell)))
  85                 ((eq (car cell) '->decomposition))
  86                 ((eq (car cell) 'composition))
  87                 ((eq (car cell) '->lowercase))
  88                 ((eq (car cell) '->uppercase))
  89                 ((eq (car cell) '->titlecase))
  90                 ((eq (car cell) '->fullwidth))
  91                 ((eq (car cell) '=ucs)
  92                  (setq ucs (cdr cell))
  93                  (setq ret
  94                        (cons (cons (if (<= ucs #xFFFF)
  95                                        '=ucs@unicode
  96                                      '=ucs@iso)
  97                                    ucs)
  98                              ret)))
  99                 ((member cell ifs))
 100                 ((eq (car cell) '->ucs-unified)
 101                  (remove-char-attribute c '->ucs-unified))
 102                 (t
 103                  (remove-char-attribute c (car cell))
 104                  (setq ret (cons cell ret)))))
 105         (setq ufs
 106               (cons (list '<-halfwidth c)
 107                     ret))
 108         (put-char-attribute c '->denotational
 109                             (cons (define-char ufs) v))
 110         (dolist (vc v)
 111           (dolist (isf ifs)
 112             (remove-char-attribute vc (car isf)))
 113           (if (eq ucs (get-char-attribute vc '=>ucs))
 114               (remove-char-attribute vc '=>ucs))
 115           (if (setq ret (get-char-attribute vc '<-fullwidth))
 116               (put-char-attribute vc '<-fullwidth
 117                                   (list c) ; (delq c ret)
 118                                   ))
 119           (if (and name
 120                    (string= (concat "fullwidth " (downcase name))
 121                             (get-char-attribute vc 'name)))
 122               (remove-char-attribute vc 'name))
 123           )
 124         ))))
 125
 126
 127 ;;; @ End.
 128 ;;;
 129
 130 (provide 'conv-util)
 131
 132 ;;; conv-util.el ends here