ids-dump.el

   1 ;;; ids-dump.el --- Dump utility of IDS-* files
   2
   3 ;; Copyright (C) 2002,2003,2004,2005,2009 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 (ideographic-structure-to-ids
 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 (ideographic-structure-to-ids
 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-basic@unicode (filename)
 278   (interactive "Fdump IDS-UCS-Basic : ")
 279   (ids-dump-range "IDS-UCS-Basic_u.txt" filename
 280                   #'ids-dump-insert-ccs-ranges '=ucs@unicode
 281                   "UU+%04X\t%c\t%s\n"
 282                   '(#x4E00 . #x9FA5)))
 283
 284 ;;;###autoload
 285 (defun ids-dump-ucs-ext-a (filename)
 286   (interactive "Fdump IDS-UCS-Ext-A : ")
 287   (ids-dump-range "IDS-UCS-Ext-A.txt" filename
 288                   #'ids-dump-insert-ccs-ranges 'ucs "U+%04X\t%c\t%s\n"
 289                   '(#x3400 . #x4DB5) #xFA1F #xFA23))
 290
 291 ;;;###autoload
 292 (defun ids-dump-ucs-compat (filename)
 293   (interactive "Fdump IDS-UCS-Compat : ")
 294   (ids-dump-range "IDS-UCS-Compat.txt" filename
 295                   #'ids-dump-insert-ccs-ranges 'ucs "U+%04X\t%c\t%s\n"
 296                   '(#xF900 . #xFA1E) '(#xFA20 . #xFA22) '(#xFA24 . #xFA2D)))
 297
 298 ;;;###autoload
 299 (defun ids-dump-ucs-ext-b-1 (filename)
 300   (interactive "Fdump IDS-UCS-Ext-B-1 : ")
 301   (ids-dump-range "IDS-UCS-Ext-B-1.txt" filename
 302                   #'ids-dump-insert-ccs-ranges 'ucs "U-%08X\t%c\t%s\n"
 303                   '(#x20000 . #x21FFF)))
 304
 305 ;;;###autoload
 306 (defun ids-dump-ucs-ext-b-2 (filename)
 307   (interactive "Fdump IDS-UCS-Ext-B-2 : ")
 308   (ids-dump-range "IDS-UCS-Ext-B-2.txt" filename
 309                   #'ids-dump-insert-ccs-ranges 'ucs "U-%08X\t%c\t%s\n"
 310                   '(#x22000 . #x23FFF)))
 311
 312 ;;;###autoload
 313 (defun ids-dump-ucs-ext-b-3 (filename)
 314   (interactive "Fdump IDS-UCS-Ext-B-3 : ")
 315   (ids-dump-range "IDS-UCS-Ext-B-3.txt" filename
 316                   #'ids-dump-insert-ccs-ranges 'ucs "U-%08X\t%c\t%s\n"
 317                   '(#x24000 . #x25FFF)))
 318
 319 ;;;###autoload
 320 (defun ids-dump-ucs-ext-b-4 (filename)
 321   (interactive "Fdump IDS-UCS-Ext-B-4 : ")
 322   (ids-dump-range "IDS-UCS-Ext-B-4.txt" filename
 323                   #'ids-dump-insert-ccs-ranges 'ucs "U-%08X\t%c\t%s\n"
 324                   '(#x26000 . #x27FFF)))
 325
 326 ;;;###autoload
 327 (defun ids-dump-ucs-ext-b-5 (filename)
 328   (interactive "Fdump IDS-UCS-Ext-B-5 : ")
 329   (ids-dump-range "IDS-UCS-Ext-B-5.txt" filename
 330                   #'ids-dump-insert-ccs-ranges 'ucs "U-%08X\t%c\t%s\n"
 331                   '(#x28000 . #x29FFF)))
 332
 333 ;;;###autoload
 334 (defun ids-dump-ucs-ext-b-6 (filename)
 335   (interactive "Fdump IDS-UCS-Ext-B-6 : ")
 336   (ids-dump-range "IDS-UCS-Ext-B-6.txt" filename
 337                   #'ids-dump-insert-ccs-ranges 'ucs "U-%08X\t%c\t%s\n"
 338                   '(#x2A000 . #x2A6D6)))
 339
 340 ;;;###autoload
 341 (defun ids-dump-ucs-compat-supplement (filename)
 342   (interactive "Fdump IDS-UCS-Compat-Supplement : ")
 343   (ids-dump-range "IDS-UCS-Compat-Supplement.txt" filename
 344                   #'ids-dump-insert-ccs-ranges 'ucs "U-%08X\t%c\t%s\n"
 345                   '(#x2F800 . #x2FA1D)))
 346
 347 ;;;###autoload
 348 (defun ids-dump-cns11643-1 (filename)
 349   (interactive "Fdump IDS-CNS-1 : ")
 350   (ids-dump-range "IDS-CNS-1.txt" filename
 351                   #'ids-dump-insert-94x94-ccs-ranges
 352                   'chinese-cns11643-1 "C1-%04X\t%c\t%s\n"
 353                   '(#x4421 . #x7D4B)))
 354
 355 ;;;###autoload
 356 (defun ids-dump-cns11643-2 (filename)
 357   (interactive "Fdump IDS-CNS-2 : ")
 358   (ids-dump-range "IDS-CNS-2.txt" filename
 359                   #'ids-dump-insert-94x94-ccs-ranges
 360                   'chinese-cns11643-2 "C2-%04X\t%c\t%s\n"
 361                   '(#x2121 . #x7244)))
 362
 363 ;;;###autoload
 364 (defun ids-dump-cns11643-3 (filename)
 365   (interactive "Fdump IDS-CNS-3 : ")
 366   (ids-dump-range "IDS-CNS-3.txt" filename
 367                   #'ids-dump-insert-94x94-ccs-ranges
 368                   'chinese-cns11643-3 "C3-%04X\t%c\t%s\n"
 369                   '(#x2121 . #x6246)))
 370
 371 ;;;###autoload
 372 (defun ids-dump-daikanwa-01 (filename)
 373   (interactive "Fdump IDS-Daikanwa-01 : ")
 374   (ids-dump-range "IDS-Daikanwa-01.txt" filename
 375                   #'ids-dump-insert-daikanwa 00001 01449))
 376
 377 ;;;###autoload
 378 (defun ids-dump-daikanwa-02 (filename)
 379   (interactive "Fdump IDS-Daikanwa-02 : ")
 380   (ids-dump-range "IDS-Daikanwa-02.txt" filename
 381                   #'ids-dump-insert-daikanwa 01450 04674))
 382
 383 ;;;###autoload
 384 (defun ids-dump-daikanwa-03 (filename)
 385   (interactive "Fdump IDS-Daikanwa-03 : ")
 386   (ids-dump-range "IDS-Daikanwa-03.txt" filename
 387                   #'ids-dump-insert-daikanwa 04675 07410))
 388
 389 ;;;###autoload
 390 (defun ids-dump-daikanwa-04 (filename)
 391   (interactive "Fdump IDS-Daikanwa-04 : ")
 392   (ids-dump-range "IDS-Daikanwa-04.txt" filename
 393                   #'ids-dump-insert-daikanwa 07411 11529))
 394
 395 ;;;###autoload
 396 (defun ids-dump-daikanwa-05 (filename)
 397   (interactive "Fdump IDS-Daikanwa-05 : ")
 398   (ids-dump-range "IDS-Daikanwa-05.txt" filename
 399                   #'ids-dump-insert-daikanwa 11530 14414))
 400
 401 ;;;###autoload
 402 (defun ids-dump-daikanwa-06 (filename)
 403   (interactive "Fdump IDS-Daikanwa-06 : ")
 404   (ids-dump-range "IDS-Daikanwa-06.txt" filename
 405                   #'ids-dump-insert-daikanwa 14415 17574))
 406
 407 ;;;###autoload
 408 (defun ids-dump-daikanwa-07 (filename)
 409   (interactive "Fdump IDS-Daikanwa-07 : ")
 410   (ids-dump-range "IDS-Daikanwa-07.txt" filename
 411                   #'ids-dump-insert-daikanwa 17575 22677))
 412
 413 ;;;###autoload
 414 (defun ids-dump-daikanwa-08 (filename)
 415   (interactive "Fdump IDS-Daikanwa-08 : ")
 416   (ids-dump-range "IDS-Daikanwa-08.txt" filename
 417                   #'ids-dump-insert-daikanwa 22678 28107))
 418
 419 ;;;###autoload
 420 (defun ids-dump-daikanwa-09 (filename)
 421   (interactive "Fdump IDS-Daikanwa-09 : ")
 422   (ids-dump-range "IDS-Daikanwa-09.txt" filename
 423                   #'ids-dump-insert-daikanwa 28108 32803))
 424
 425 ;;;###autoload
 426 (defun ids-dump-daikanwa-10 (filename)
 427   (interactive "Fdump IDS-Daikanwa-10 : ")
 428   (ids-dump-range "IDS-Daikanwa-10.txt" filename
 429                   #'ids-dump-insert-daikanwa 32804 38699))
 430
 431 ;;;###autoload
 432 (defun ids-dump-daikanwa-11 (filename)
 433   (interactive "Fdump IDS-Daikanwa-11 : ")
 434   (ids-dump-range "IDS-Daikanwa-11.txt" filename
 435                   #'ids-dump-insert-daikanwa 38700 42209))
 436
 437 ;;;###autoload
 438 (defun ids-dump-daikanwa-12 (filename)
 439   (interactive "Fdump IDS-Daikanwa-12 : ")
 440   (ids-dump-range "IDS-Daikanwa-12.txt" filename
 441                   #'ids-dump-insert-daikanwa 42210 48902))
 442
 443 ;;;###autoload
 444 (defun ids-dump-daikanwa-index (filename)
 445   (interactive "Fdump IDS-Daikanwa-dx : ")
 446   (ids-dump-range "IDS-Daikanwa-dx.txt" filename
 447                   #'ids-dump-insert-daikanwa 48903 49964))
 448
 449 ;;;###autoload
 450 (defun ids-dump-daikanwa-hokan (filename)
 451   (interactive "Fdump IDS-Daikanwa-ho : ")
 452   (ids-dump-range "IDS-Daikanwa-ho.txt" filename
 453                   #'ids-dump-insert-daikanwa-hokan))
 454
 455 ;;;###autoload
 456 (defun ids-dump-cbeta (filename)
 457   (interactive "Fdump IDS-CBETA : ")
 458   (ids-dump-range "IDS-CBETA.txt" filename
 459                   #'ids-dump-insert-ccs-ranges
 460                   'ideograph-cbeta "CB%05d\t%c\t%s\n"
 461                   '(1 . 13363)))
 462
 463 ;;;###autoload
 464 (defun ids-dump-jis-x0208-1990 (filename)
 465   (interactive "Fdump IDS-JIS-X0208-1990 : ")
 466   (ids-dump-range "IDS-JIS-X0208-1990.txt" filename
 467                   #'ids-dump-insert-jis-x0208-1990))
 468
 469 ;;;###autoload
 470 (defun ids-dump-big5-cdp (filename)
 471   (interactive "Fdump IDS-CDP : ")
 472   (ids-dump-range "IDS-CDP.txt" filename
 473                   #'ids-dump-insert-big5-pua
 474                   '=big5-cdp "CDP-"))
 475
 476
 477 ;;; @ End.
 478 ;;;
 479
 480 (provide 'ids-dump)
 481
 482 ;;; ids-dump.el ends here