ids-dump.el

   1 ;;; ids-dump.el --- Dump utility of IDS-* files
   2
   3 ;; Copyright (C) 2002,2003,2004,2005 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 (defun ids-dump-format-list (ids-list)
  30   (if ids-list
  31       (let (ucs)
  32         (mapconcat
  33          (lambda (c)
  34            (char-to-string
  35             (if (setq ucs
  36                       (unless (encode-char c '=ucs 'defined-only)
  37                         (or (get-char-attribute c '=ucs@unicode)
  38                             (get-char-attribute c '=ucs@iso))))
  39                 (decode-char '=ucs ucs)
  40               c)))
  41          (ids-format-list ids-list) ""))))
  42
  43 (defun ids-dump-insert-line (ccs line-spec code)
  44   (let ((chr (decode-char ccs code))
  45         id-list)
  46     (when chr
  47       (setq id-list (get-char-attribute chr 'ideographic-structure))
  48       (insert (format line-spec
  49                       code (decode-builtin-char ccs code)
  50                       (if id-list
  51                           (ids-dump-format-list id-list)
  52                         (char-to-string chr)))))))
  53
  54 (defun ids-dump-insert-ccs-ranges (ccs line-spec &rest ranges)
  55   (let (range code max-code)
  56     (while ranges
  57       (setq range (car ranges))
  58       (cond ((consp range)
  59              (setq code (car range)
  60                    max-code (cdr range))
  61              (while (<= code max-code)
  62                (ids-dump-insert-line ccs line-spec code)
  63                (setq code (1+ code))))
  64             ((integerp range)
  65              (ids-dump-insert-line ccs line-spec range))
  66             (t (error 'wrong-type-argument range)))
  67       (setq ranges (cdr ranges)))))
  68
  69 (defun ids-dump-insert-94x94-ccs-ranges (ccs line-spec &rest ranges)
  70   (let (range code max-code l)
  71     (while ranges
  72       (setq range (car ranges))
  73       (cond ((consp range)
  74              (setq code (car range)
  75                    max-code (cdr range))
  76              (while (<= code max-code)
  77                (setq l (logand code 255))
  78                (if (and (<= #x21 l)(<= l #x7E))
  79                    (ids-dump-insert-line ccs line-spec code))
  80                (setq code (1+ code))))
  81             ((integerp range)
  82              (ids-dump-insert-line ccs line-spec range))
  83             (t (error 'wrong-type-argument range)))
  84       (setq ranges (cdr ranges)))))
  85
  86 (defun ids-dump-insert-daikanwa (start end)
  87   (let ((i start)
  88         mdh-alist
  89         chr sal)
  90     (map-char-attribute
  91      (lambda (key val)
  92        (when (= (length val) 2)
  93          (set-alist 'mdh-alist
  94                     (car val)
  95                     (put-alist (nth 1 val)
  96                                key
  97                                (cdr (assq (car val) mdh-alist)))))
  98        nil)
  99      'morohashi-daikanwa)
 100     (while (<= i end)
 101       (when (setq chr (decode-char 'ideograph-daikanwa i))
 102         (insert
 103          (format "M-%05d \t%c\t%s\n"
 104                  i (decode-builtin-char 'ideograph-daikanwa i)
 105                  (or (ids-dump-format-list
 106                       (get-char-attribute chr 'ideographic-structure))
 107                      ""))))
 108       (when (setq sal (assq i mdh-alist))
 109         (setq sal (cdr sal))
 110         (when (setq chr (assq 1 sal))
 111           (setq chr (cdr chr))
 112           (insert
 113            (format "M-%05d'\t%c\t%s\n"
 114                    i chr
 115                    (or (ids-dump-format-list
 116                         (get-char-attribute chr 'ideographic-structure))
 117                        ""))))
 118         (when (setq chr (assq 2 sal))
 119           (setq chr (cdr chr))
 120           (insert
 121            (format "M-%05d\"\t%c\t%s\n"
 122                    i chr
 123                    (ids-dump-format-list
 124                     (get-char-attribute chr 'ideographic-structure)))))
 125         )
 126       (setq i (1+ i)))))
 127
 128 (defun ids-dump-insert-daikanwa-hokan ()
 129   (let (chr sal)
 130     (map-char-attribute
 131      (lambda (key val)
 132        (when (and (eq (car val) 'ho)
 133                   (null (nthcdr 2 val)))
 134          (setq sal (cons (cons (nth 1 val) key) sal)))
 135        nil)
 136      'morohashi-daikanwa)
 137     (setq sal (sort sal (lambda (a b) (< (car a)(car b)))))
 138     (dolist (cell sal)
 139       (setq chr (cdr cell))
 140       (insert
 141        (format "MH-%04d \t%c\t%s\n"
 142                (car cell)
 143                chr
 144                (or (ids-dump-format-list
 145                     (get-char-attribute chr 'ideographic-structure))
 146                    ""))))))
 147
 148 (defun ids-dump-insert-jis-x0208-1990 ()
 149   (let ((row 16)
 150         cell h l code chr)
 151     (while (<= row 83)
 152       (setq h (+ row 32))
 153       (setq cell 1)
 154       (while (<= cell 94)
 155         (setq l (+ cell 32))
 156         (setq chr (make-char 'japanese-jisx0208-1990 h l))
 157         (insert
 158          (format "J90-%02X%02X\t%c\t%s\n"
 159                  h l
 160                  (decode-builtin-char 'japanese-jisx0208-1990
 161                                       (logior (lsh h 8) l))
 162                  (or (ids-dump-format-list
 163                       (get-char-attribute chr 'ideographic-structure))
 164                      "")))
 165         (setq cell (1+ cell)))
 166       (setq row (1+ row)))
 167     (setq h (+ row 32))
 168     (setq cell 1)
 169     (while (<= cell 6)
 170       (setq l (+ cell 32))
 171       (setq chr (make-char 'japanese-jisx0208-1990 h l))
 172       (insert
 173        (format "J90-%02X%02X\t%c\t%s\n"
 174                h l
 175                (decode-builtin-char 'japanese-jisx0208-1990
 176                                     (logior (lsh h 8) l))
 177                (or (ids-dump-format-list
 178                     (get-char-attribute chr 'ideographic-structure))
 179                    "")))
 180       (setq cell (1+ cell)))))
 181
 182 (defun ids-dump-insert-big5 (ccs prefix)
 183   (let ((h #x81)
 184         l code chr structure)
 185     (while (<= h #xFE)
 186       (setq l #x40)
 187       (while (<= l #x7E)
 188         (setq chr (make-char ccs h l))
 189         (setq structure nil)
 190         (when (setq structure
 191                     (get-char-attribute chr 'ideographic-structure))
 192           (insert
 193            (format "%s%02X%02X\t%c\t%s\n"
 194                    prefix h l
 195                    (decode-builtin-char ccs
 196                                         (logior (lsh h 8) l))
 197                    (or (ids-format-list
 198                         (get-char-attribute chr 'ideographic-structure))
 199                        ""))))
 200         (setq l (1+ l)))
 201       (setq l #xA1)
 202       (while (<= l #xFE)
 203         (setq chr (make-char ccs h l))
 204         (setq structure nil)
 205         (when (setq structure
 206                     (get-char-attribute chr 'ideographic-structure))
 207           (insert
 208            (format "%s%02X%02X\t%c\t%s\n"
 209                    prefix h l
 210                    (decode-builtin-char ccs
 211                                         (logior (lsh h 8) l))
 212                    (or (ids-format-list
 213                         (get-char-attribute chr 'ideographic-structure))
 214                        ""))))
 215         (setq l (1+ l)))
 216       (setq h (1+ h)))))
 217
 218 (defun ids-dump-insert-big5-pua (ccs prefix)
 219   (let ((line-spec (concat prefix "%04X\t%c\t%s\n"))
 220         (h #x81)
 221         l)
 222     (while (<= h #xA0)
 223       (setq l #x40)
 224       (while (<= l #x7E)
 225         (ids-dump-insert-line ccs line-spec (logior (lsh h 8) l))
 226         (setq l (1+ l)))
 227       (setq l #xA1)
 228       (while (<= l #xFE)
 229         (ids-dump-insert-line ccs line-spec (logior (lsh h 8) l))
 230         (setq l (1+ l)))
 231       (setq h (1+ h)))
 232     (setq h #xC6)
 233     (setq l #xDE)
 234     (while (<= l #xFE)
 235       (ids-dump-insert-line ccs line-spec (logior (lsh h 8) l))
 236       (setq l (1+ l)))
 237     (setq h #xC7)
 238     (while (<= h #xC8)
 239       (setq l #x40)
 240       (while (<= l #x7E)
 241         (ids-dump-insert-line ccs line-spec (logior (lsh h 8) l))
 242         (setq l (1+ l)))
 243       (setq l #xA1)
 244       (while (<= l #xFE)
 245         (ids-dump-insert-line ccs line-spec (logior (lsh h 8) l))
 246         (setq l (1+ l)))
 247       (setq h (1+ h)))
 248     (setq h #xFA)
 249     (while (<= h #xFE)
 250       (setq l #x40)
 251       (while (<= l #x7E)
 252         (ids-dump-insert-line ccs line-spec (logior (lsh h 8) l))
 253         (setq l (1+ l)))
 254       (setq l #xA1)
 255       (while (<= l #xFE)
 256         (ids-dump-insert-line ccs line-spec (logior (lsh h 8) l))
 257         (setq l (1+ l)))
 258       (setq h (1+ h)))))
 259
 260 (defun ids-dump-range (file path func &rest args)
 261   (with-temp-buffer
 262     (let* ((coding-system-for-write 'utf-8-mcs-er))
 263       (if (file-directory-p path)
 264           (setq path (expand-file-name file path)))
 265       (insert ";; -*- coding: utf-8-mcs-er -*-\n")
 266       (apply func args)
 267       (write-region (point-min)(point-max) path))))
 268
 269 ;;;###autoload
 270 (defun ids-dump-ucs-basic (filename)
 271   (interactive "Fdump IDS-UCS-Basic : ")
 272   (ids-dump-range "IDS-UCS-Basic.txt" filename
 273                   #'ids-dump-insert-ccs-ranges 'ucs "U+%04X\t%c\t%s\n"
 274                   '(#x4E00 . #x9FA5)))
 275
 276 ;;;###autoload
 277 (defun ids-dump-ucs-ext-a (filename)
 278   (interactive "Fdump IDS-UCS-Ext-A : ")
 279   (ids-dump-range "IDS-UCS-Ext-A.txt" filename
 280                   #'ids-dump-insert-ccs-ranges 'ucs "U+%04X\t%c\t%s\n"
 281                   '(#x3400 . #x4DB5) #xFA1F #xFA23))
 282
 283 ;;;###autoload
 284 (defun ids-dump-ucs-compat (filename)
 285   (interactive "Fdump IDS-UCS-Compat : ")
 286   (ids-dump-range "IDS-UCS-Compat.txt" filename
 287                   #'ids-dump-insert-ccs-ranges 'ucs "U+%04X\t%c\t%s\n"
 288                   '(#xF900 . #xFA1E) '(#xFA20 . #xFA22) '(#xFA24 . #xFA2D)))
 289
 290 ;;;###autoload
 291 (defun ids-dump-ucs-ext-b-1 (filename)
 292   (interactive "Fdump IDS-UCS-Ext-B-1 : ")
 293   (ids-dump-range "IDS-UCS-Ext-B-1.txt" filename
 294                   #'ids-dump-insert-ccs-ranges 'ucs "U-%08X\t%c\t%s\n"
 295                   '(#x20000 . #x21FFF)))
 296
 297 ;;;###autoload
 298 (defun ids-dump-ucs-ext-b-2 (filename)
 299   (interactive "Fdump IDS-UCS-Ext-B-2 : ")
 300   (ids-dump-range "IDS-UCS-Ext-B-2.txt" filename
 301                   #'ids-dump-insert-ccs-ranges 'ucs "U-%08X\t%c\t%s\n"
 302                   '(#x22000 . #x23FFF)))
 303
 304 ;;;###autoload
 305 (defun ids-dump-ucs-ext-b-3 (filename)
 306   (interactive "Fdump IDS-UCS-Ext-B-3 : ")
 307   (ids-dump-range "IDS-UCS-Ext-B-3.txt" filename
 308                   #'ids-dump-insert-ccs-ranges 'ucs "U-%08X\t%c\t%s\n"
 309                   '(#x24000 . #x25FFF)))
 310
 311 ;;;###autoload
 312 (defun ids-dump-ucs-ext-b-4 (filename)
 313   (interactive "Fdump IDS-UCS-Ext-B-4 : ")
 314   (ids-dump-range "IDS-UCS-Ext-B-4.txt" filename
 315                   #'ids-dump-insert-ccs-ranges 'ucs "U-%08X\t%c\t%s\n"
 316                   '(#x26000 . #x27FFF)))
 317
 318 ;;;###autoload
 319 (defun ids-dump-ucs-ext-b-5 (filename)
 320   (interactive "Fdump IDS-UCS-Ext-B-5 : ")
 321   (ids-dump-range "IDS-UCS-Ext-B-5.txt" filename
 322                   #'ids-dump-insert-ccs-ranges 'ucs "U-%08X\t%c\t%s\n"
 323                   '(#x28000 . #x29FFF)))
 324
 325 ;;;###autoload
 326 (defun ids-dump-ucs-ext-b-6 (filename)
 327   (interactive "Fdump IDS-UCS-Ext-B-6 : ")
 328   (ids-dump-range "IDS-UCS-Ext-B-6.txt" filename
 329                   #'ids-dump-insert-ccs-ranges 'ucs "U-%08X\t%c\t%s\n"
 330                   '(#x2A000 . #x2A6D6)))
 331
 332 ;;;###autoload
 333 (defun ids-dump-ucs-compat-supplement (filename)
 334   (interactive "Fdump IDS-UCS-Compat-Supplement : ")
 335   (ids-dump-range "IDS-UCS-Compat-Supplement.txt" filename
 336                   #'ids-dump-insert-ccs-ranges 'ucs "U-%08X\t%c\t%s\n"
 337                   '(#x2F800 . #x2FA1D)))
 338
 339 ;;;###autoload
 340 (defun ids-dump-cns11643-1 (filename)
 341   (interactive "Fdump IDS-CNS-1 : ")
 342   (ids-dump-range "IDS-CNS-1.txt" filename
 343                   #'ids-dump-insert-94x94-ccs-ranges
 344                   'chinese-cns11643-1 "C1-%04X\t%c\t%s\n"
 345                   '(#x4421 . #x7D4B)))
 346
 347 ;;;###autoload
 348 (defun ids-dump-cns11643-2 (filename)
 349   (interactive "Fdump IDS-CNS-2 : ")
 350   (ids-dump-range "IDS-CNS-2.txt" filename
 351                   #'ids-dump-insert-94x94-ccs-ranges
 352                   'chinese-cns11643-2 "C2-%04X\t%c\t%s\n"
 353                   '(#x2121 . #x7244)))
 354
 355 ;;;###autoload
 356 (defun ids-dump-cns11643-3 (filename)
 357   (interactive "Fdump IDS-CNS-3 : ")
 358   (ids-dump-range "IDS-CNS-3.txt" filename
 359                   #'ids-dump-insert-94x94-ccs-ranges
 360                   'chinese-cns11643-3 "C3-%04X\t%c\t%s\n"
 361                   '(#x2121 . #x6246)))
 362
 363 ;;;###autoload
 364 (defun ids-dump-daikanwa-01 (filename)
 365   (interactive "Fdump IDS-Daikanwa-01 : ")
 366   (ids-dump-range "IDS-Daikanwa-01.txt" filename
 367                   #'ids-dump-insert-daikanwa 00001 01449))
 368
 369 ;;;###autoload
 370 (defun ids-dump-daikanwa-02 (filename)
 371   (interactive "Fdump IDS-Daikanwa-02 : ")
 372   (ids-dump-range "IDS-Daikanwa-02.txt" filename
 373                   #'ids-dump-insert-daikanwa 01450 04674))
 374
 375 ;;;###autoload
 376 (defun ids-dump-daikanwa-03 (filename)
 377   (interactive "Fdump IDS-Daikanwa-03 : ")
 378   (ids-dump-range "IDS-Daikanwa-03.txt" filename
 379                   #'ids-dump-insert-daikanwa 04675 07410))
 380
 381 ;;;###autoload
 382 (defun ids-dump-daikanwa-04 (filename)
 383   (interactive "Fdump IDS-Daikanwa-04 : ")
 384   (ids-dump-range "IDS-Daikanwa-04.txt" filename
 385                   #'ids-dump-insert-daikanwa 07411 11529))
 386
 387 ;;;###autoload
 388 (defun ids-dump-daikanwa-05 (filename)
 389   (interactive "Fdump IDS-Daikanwa-05 : ")
 390   (ids-dump-range "IDS-Daikanwa-05.txt" filename
 391                   #'ids-dump-insert-daikanwa 11530 14414))
 392
 393 ;;;###autoload
 394 (defun ids-dump-daikanwa-06 (filename)
 395   (interactive "Fdump IDS-Daikanwa-06 : ")
 396   (ids-dump-range "IDS-Daikanwa-06.txt" filename
 397                   #'ids-dump-insert-daikanwa 14415 17574))
 398
 399 ;;;###autoload
 400 (defun ids-dump-daikanwa-07 (filename)
 401   (interactive "Fdump IDS-Daikanwa-07 : ")
 402   (ids-dump-range "IDS-Daikanwa-07.txt" filename
 403                   #'ids-dump-insert-daikanwa 17575 22677))
 404
 405 ;;;###autoload
 406 (defun ids-dump-daikanwa-08 (filename)
 407   (interactive "Fdump IDS-Daikanwa-08 : ")
 408   (ids-dump-range "IDS-Daikanwa-08.txt" filename
 409                   #'ids-dump-insert-daikanwa 22678 28107))
 410
 411 ;;;###autoload
 412 (defun ids-dump-daikanwa-09 (filename)
 413   (interactive "Fdump IDS-Daikanwa-09 : ")
 414   (ids-dump-range "IDS-Daikanwa-09.txt" filename
 415                   #'ids-dump-insert-daikanwa 28108 32803))
 416
 417 ;;;###autoload
 418 (defun ids-dump-daikanwa-10 (filename)
 419   (interactive "Fdump IDS-Daikanwa-10 : ")
 420   (ids-dump-range "IDS-Daikanwa-10.txt" filename
 421                   #'ids-dump-insert-daikanwa 32804 38699))
 422
 423 ;;;###autoload
 424 (defun ids-dump-daikanwa-11 (filename)
 425   (interactive "Fdump IDS-Daikanwa-11 : ")
 426   (ids-dump-range "IDS-Daikanwa-11.txt" filename
 427                   #'ids-dump-insert-daikanwa 38700 42209))
 428
 429 ;;;###autoload
 430 (defun ids-dump-daikanwa-12 (filename)
 431   (interactive "Fdump IDS-Daikanwa-12 : ")
 432   (ids-dump-range "IDS-Daikanwa-12.txt" filename
 433                   #'ids-dump-insert-daikanwa 42210 48902))
 434
 435 ;;;###autoload
 436 (defun ids-dump-daikanwa-index (filename)
 437   (interactive "Fdump IDS-Daikanwa-dx : ")
 438   (ids-dump-range "IDS-Daikanwa-dx.txt" filename
 439                   #'ids-dump-insert-daikanwa 48903 49964))
 440
 441 ;;;###autoload
 442 (defun ids-dump-daikanwa-hokan (filename)
 443   (interactive "Fdump IDS-Daikanwa-ho : ")
 444   (ids-dump-range "IDS-Daikanwa-ho.txt" filename
 445                   #'ids-dump-insert-daikanwa-hokan))
 446
 447 ;;;###autoload
 448 (defun ids-dump-cbeta (filename)
 449   (interactive "Fdump IDS-CBETA : ")
 450   (ids-dump-range "IDS-CBETA.txt" filename
 451                   #'ids-dump-insert-ccs-ranges
 452                   'ideograph-cbeta "CB%05d\t%c\t%s\n"
 453                   '(1 . 13363)))
 454
 455 ;;;###autoload
 456 (defun ids-dump-jis-x0208-1990 (filename)
 457   (interactive "Fdump IDS-JIS-X0208-1990 : ")
 458   (ids-dump-range "IDS-JIS-X0208-1990.txt" filename
 459                   #'ids-dump-insert-jis-x0208-1990))
 460
 461 ;;;###autoload
 462 (defun ids-dump-big5-cdp (filename)
 463   (interactive "Fdump IDS-CDP : ")
 464   (ids-dump-range "IDS-CDP.txt" filename
 465                   #'ids-dump-insert-big5-pua
 466                   '=big5-cdp "CDP-"))
 467
 468
 469 ;;; @ End.
 470 ;;;
 471
 472 (provide 'ids-dump)
 473
 474 ;;; ids-dump.el ends here