ids-dump.el

   1 ;;; ids-dump.el --- Dump utility of IDS-* files
   2
   3 ;; Copyright (C) 2002 MORIOKA Tomohiko
   4
   5 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
   6 ;; Keywords: IDS, IDC, Ideographs, UCS, Unicode
   7
   8 ;; This file is a part of IDS.
   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 'ids)
  28
  29 (defvar ids-dump-file-specs-alist
  30   '((ucs-basic "IDS-UCS-Basic.txt"
  31                ids-dump-insert-ccs-ranges
  32                ucs "U+%04X\t%c\t%s\n"
  33                (#x4E00 . #x9FA5))
  34     (ucs-ext-a "IDS-UCS-Ext-A.txt"
  35                ids-dump-insert-ccs-ranges
  36                ucs "U+%04X\t%c\t%s\n"
  37                (#x3400 . #x4DB5) #xFA1F #xFA23)
  38     (ucs-compat "IDS-UCS-Compat.txt"
  39                 ids-dump-insert-ccs-ranges
  40                 ucs "U+%04X\t%c\t%s\n"
  41                 (#xF900 . #xFA1E) (#xFA20 . #xFA22) (#xFA24 . #xFA2D))
  42     (ucs-ext-b-1 "IDS-UCS-Ext-B-1.txt"
  43                  ids-dump-insert-ccs-ranges
  44                  ucs "U-%08X\t%c\t%s\n"
  45                  (#x20000 . #x21FFF))
  46     (ucs-ext-b-2 "IDS-UCS-Ext-B-2.txt"
  47                  ids-dump-insert-ccs-ranges
  48                  ucs "U-%08X\t%c\t%s\n"
  49                  (#x22000 . #x23FFF))
  50     (ucs-ext-b-3 "IDS-UCS-Ext-B-3.txt"
  51                  ids-dump-insert-ccs-ranges
  52                  ucs "U-%08X\t%c\t%s\n"
  53                  (#x24000 . #x25FFF))
  54     (ucs-ext-b-4 "IDS-UCS-Ext-B-4.txt"
  55                  ids-dump-insert-ccs-ranges
  56                  ucs "U-%08X\t%c\t%s\n"
  57                  (#x26000 . #x27FFF))
  58     (ucs-ext-b-5 "IDS-UCS-Ext-B-5.txt"
  59                  ids-dump-insert-ccs-ranges
  60                  ucs "U-%08X\t%c\t%s\n"
  61                  (#x28000 . #x29FFF))
  62     (ucs-ext-b-6 "IDS-UCS-Ext-B-6.txt"
  63                  ids-dump-insert-ccs-ranges
  64                  ucs "U-%08X\t%c\t%s\n"
  65                  (#x2A000 . #x2A6D6))
  66     (ucs-compat-supplement "IDS-UCS-Compat-Supplement.txt"
  67                            ids-dump-insert-ccs-ranges
  68                            ucs "U-%08X\t%c\t%s\n"
  69                            (#x2F800 . #x2FA1D))
  70     (daikanwa "IDS-Daikanwa.txt" ids-dump-insert-daikanwa)
  71     (cbeta "IDS-CBETA.txt"
  72            ids-dump-insert-ccs-ranges
  73            ideograph-cbeta "CB%05d\t%c\t%s\n"
  74            (1 . 13363))
  75     ))
  76
  77 (defun ids-dump-insert-line (ccs line-spec code)
  78   (let ((chr (decode-char ccs code))
  79         id-list)
  80     (when chr
  81       (setq id-list (get-char-attribute chr 'ideographic-structure))
  82       (insert (format line-spec
  83                       code (decode-builtin-char ccs code)
  84                       (if id-list
  85                           (ids-format-list id-list)
  86                         (char-to-string chr)))))))
  87
  88 (defun ids-dump-insert-ccs-ranges (ccs line-spec &rest ranges)
  89   (let (range code max-code)
  90     (while ranges
  91       (setq range (car ranges))
  92       (cond ((consp range)
  93              (setq code (car range)
  94                    max-code (cdr range))
  95              (while (<= code max-code)
  96                (ids-dump-insert-line ccs line-spec code)
  97                (setq code (1+ code))))
  98             ((integerp range)
  99              (ids-dump-insert-line ccs line-spec range))
 100             (t (error 'wrong-type-argument range)))
 101       (setq ranges (cdr ranges)))))
 102
 103 (defun ids-dump-ranges (range filename)
 104   (with-temp-buffer
 105     (let* ((coding-system-for-write 'utf-8)
 106            (spec (assq range ids-dump-file-specs-alist))
 107            (file (nth 1 spec))
 108            (func (nth 2 spec))
 109            (args (nthcdr 3 spec)))
 110       (if (file-directory-p filename)
 111           (setq filename (expand-file-name file filename)))
 112       (insert ";; -*- coding: utf-8 -*-\n")
 113       (apply func args)
 114       (write-region (point-min)(point-max)
 115                     filename))))
 116
 117 (defun ids-dump-insert-daikanwa ()
 118   (let ((i 1)
 119         mdh-alist
 120         chr sal)
 121     (map-char-attribute
 122      (lambda (key val)
 123        (when (= (length val) 2)
 124          (set-alist 'mdh-alist
 125                     (car val)
 126                     (put-alist (nth 1 val)
 127                                key
 128                                (cdr (assq (car val) mdh-alist)))))
 129        nil)
 130      'morohashi-daikanwa)
 131     (while (<= i 49964)
 132       (when (setq chr (decode-char 'ideograph-daikanwa i))
 133         (insert
 134          (format "M-%05d \t%c\t%s\n"
 135                  i (decode-builtin-char 'ideograph-daikanwa i)
 136                  (ids-format-list
 137                   (get-char-attribute chr 'ideographic-structure)))))
 138       (when (setq sal (assq i mdh-alist))
 139         (setq sal (cdr sal))
 140         (when (setq chr (assq 1 sal))
 141           (setq chr (cdr chr))
 142           (insert
 143            (format "M-%05d'\t%c\t%s\n"
 144                    i chr
 145                    (ids-format-list
 146                     (get-char-attribute chr 'ideographic-structure)))))
 147         (when (setq chr (assq 2 sal))
 148           (setq chr (cdr chr))
 149           (insert
 150            (format "M-%05d\"\t%c\t%s\n"
 151                    i chr
 152                    (ids-format-list
 153                     (get-char-attribute chr 'ideographic-structure)))))
 154         )
 155       (setq i (1+ i)))
 156     (setq sal (sort (cdr (assq 'ho mdh-alist))
 157                     (lambda (a b)
 158                       (< (car a)(car b)))))
 159     (dolist (cell sal)
 160       (setq chr (cdr cell))
 161       (insert
 162        (format "MH-%04d \t%c\t%s\n"
 163                (car cell)
 164                chr
 165                (ids-format-list
 166                 (get-char-attribute chr 'ideographic-structure)))))))
 167
 168 (dolist (spec ids-dump-file-specs-alist)
 169   (eval `(defun ,(intern (concat "ids-dump-" (symbol-name (car spec))))
 170            (filename)
 171            (interactive ,(concat "Fdump "
 172                                  (file-name-sans-extension (nth 1 spec))
 173                                  " : "))
 174            (ids-dump-ranges ',(car spec) filename))))
 175
 176
 177 ;;; @ End.
 178 ;;;
 179
 180 (provide 'ids-dump)
 181
 182 ;;; ids-dump.el ends here