dump-tables.el

   1 ;;; dump-tables.el --- Dump utility of mapping tables
   2
   3 ;; Copyright (C) 2002 MORIOKA Tomohiko
   4
   5 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
   6 ;; Keywords: Ideographs, Character Database, UTF-2000, 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 (defun dump-94x94-ccs-to-ucs-table (filename default-file-name
  28                                              ccs ccs-prefix
  29                                              ucs-ccs ucs-ccs-prefix)
  30   (if (file-directory-p filename)
  31       (setq filename (expand-file-name default-file-name filename)))
  32   (with-temp-buffer
  33     (let ((ucs-ccs-map (intern (format "=>%s" ucs-ccs)))
  34           (ccs-format (concat ccs-prefix "%02X%02X"))
  35           (ucs-ccs-format (concat "\t" ucs-ccs-prefix "%04X\t"))
  36           (row 33)
  37           cell chr ucs ucs-l)
  38       (while (< row 127)
  39         (setq cell 33)
  40         (while (< cell 127)
  41           (when (and (setq chr (make-char ccs row cell))
  42                      (setq ucs (or (get-char-attribute chr 'ucs)
  43                                    (get-char-attribute chr '=>ucs))))
  44             (setq ucs-l (or (get-char-attribute chr ucs-ccs)
  45                             (get-char-attribute chr ucs-ccs-map)))
  46             (insert (format ccs-format row cell))
  47             (if (and ucs-l (/= ucs-l ucs))
  48                 (insert (format ucs-ccs-format ucs-l))
  49               (insert "\t "))
  50             (insert (format (if (<= ucs #xFFFF)
  51                                 "U+%04X\n"
  52                               "U-%08X\n")
  53                             ucs)))
  54           (setq cell (1+ cell)))
  55         (setq row (1+ row))))
  56     (write-region (point-min)(point-max) filename)))
  57
  58 ;;;###autoload
  59 (defun dump-jis-x0208-1990-to-ucs-table (filename)
  60   (interactive "Fdump J90-to-UCS : ")
  61   (dump-94x94-ccs-to-ucs-table
  62    filename "J90-to-UCS.txt"
  63    'japanese-jisx0208-1990 "J90-" 'ucs-jis "JU+"))
  64
  65 ;;;###autoload
  66 (defun dump-jis-x0212-to-ucs-table (filename)
  67   (interactive "Fdump JSP-to-UCS : ")
  68   (dump-94x94-ccs-to-ucs-table
  69    filename "JSP-to-UCS.txt"
  70    'japanese-jisx0212 "JSP-" 'ucs-jis "JU+"))
  71
  72 ;;;###autoload
  73 (defun dump-jis-x0213-1-to-ucs-table (filename)
  74   (interactive "Fdump JX1-to-UCS : ")
  75   (if (file-directory-p filename)
  76       (setq filename (expand-file-name "JX1-to-UCS.txt" filename)))
  77   (with-temp-buffer
  78     (let ((row 33)
  79           cell chr ucs ucs-j)
  80       (while (< row 127)
  81         (setq cell 33)
  82         (while (< cell 127)
  83           (when (and (setq chr (make-char 'japanese-jisx0213-1 row cell))
  84                      (not (encode-char chr 'japanese-jisx0208-1990 t))
  85                      (setq ucs (or (get-char-attribute chr 'ucs)
  86                                    (get-char-attribute chr '=>ucs)
  87                                    (get-char-attribute chr '->ucs))))
  88             (when (setq ucs-j
  89                         (or (encode-char chr '=ucs-jis-2000 'defined-only)
  90                             (get-char-attribute chr '=>ucs-jis)))
  91               (if (eq ucs-j ucs)
  92                   (setq ucs-j nil)))
  93             (insert (format "JX1-%02X%02X" row cell))
  94             (if ucs-j
  95                 (insert (format "\tJU+%04X\t" ucs-j))
  96               (insert "\t "))
  97             (insert (format (if (<= ucs #xFFFF)
  98                                 "U+%04X\n"
  99                               "U-%08X\n")
 100                             ucs)))
 101           (setq cell (1+ cell)))
 102         (setq row (1+ row))))
 103     (write-region (point-min)(point-max) filename)))
 104
 105 ;;;###autoload
 106 (defun dump-jis-x0213-2-to-ucs-table (filename)
 107   (interactive "Fdump JX2-to-UCS : ")
 108   (dump-94x94-ccs-to-ucs-table
 109    filename "JX2-to-UCS.txt"
 110    'japanese-jisx0213-2 "JX2-" 'ucs-jis "JU+"))
 111
 112 ;;;###autoload
 113 (defun dump-cns-11643-3-to-ucs-table (filename)
 114   (interactive "Fdump C3-to-UCS : ")
 115   (dump-94x94-ccs-to-ucs-table
 116    filename "C3-to-UCS.txt"
 117    'chinese-cns11643-3 "C3-" 'ucs-cns "CU+"))
 118
 119 ;;;###autoload
 120 (defun dump-cns-11643-4-to-ucs-table (filename)
 121   (interactive "Fdump C4-to-UCS : ")
 122   (dump-94x94-ccs-to-ucs-table
 123    filename "C4-to-UCS.txt"
 124    'chinese-cns11643-4 "C4-" 'ucs-cns "CU+"))
 125
 126 ;;;###autoload
 127 (defun dump-big5-to-ucs-table (filename)
 128   (interactive "Fdump B-to-UCS : ")
 129   (if (file-directory-p filename)
 130       (setq filename (expand-file-name "B-to-UCS.txt" filename)))
 131   (with-temp-buffer
 132     (let ((row #xA1)
 133           cell chr ucs ucs-big5)
 134       (while (<= row #xFE)
 135         (setq cell #x40)
 136         (while (< cell #xFE)
 137           (when (and (setq chr (make-char 'chinese-big5 row cell))
 138                      (setq ucs (or (get-char-attribute chr 'ucs)
 139                                    (get-char-attribute chr '=>ucs)
 140                                    (get-char-attribute chr '->ucs))))
 141             (setq ucs-big5 (or (get-char-attribute chr 'ucs-big5)
 142                                (get-char-attribute chr '=>ucs-big5)))
 143             (insert (format "B-%02X%02X" row cell))
 144             (if ucs-big5
 145                 (insert (format "\tBU+%04X\t" ucs-big5))
 146               (insert "\t "))
 147             (insert (format (if (<= ucs #xFFFF)
 148                                 "U+%04X\n"
 149                               "U-%08X\n")
 150                             ucs)))
 151           (setq cell (1+ cell)))
 152         (setq row (1+ row))))
 153     (write-region (point-min)(point-max) filename)))
 154
 155 ;;;###autoload
 156 (defun dump-jef-china3-to-ucs-table (filename)
 157   (interactive "Fdump JC3-to-UCS : ")
 158   (if (file-directory-p filename)
 159       (setq filename (expand-file-name "JC3-to-UCS.txt" filename)))
 160   (with-temp-buffer
 161     (let ((row #x41)
 162           cell chr ucs)
 163       (while (<= row #x9F)
 164         (setq cell #xA1)
 165         (while (<= cell #xFE)
 166           (when (and (setq chr (make-char 'china3-jef row cell))
 167                      (setq ucs (or (get-char-attribute chr 'ucs)
 168                                    (get-char-attribute chr '=>ucs))))
 169             (insert (format "JC3-%02X%02X\t" row cell))
 170             (insert (format (if (<= ucs #xFFFF)
 171                                 "U+%04X\n"
 172                               "U-%08X\n")
 173                             ucs)))
 174           (setq cell (1+ cell)))
 175         (setq row (1+ row))))
 176     (write-region (point-min)(point-max) filename)))
 177
 178 ;;;###autoload
 179 (defun dump-cbeta-to-ucs-table (filename)
 180   (interactive "Fdump CBETA-to-UCS : ")
 181   (if (file-directory-p filename)
 182       (setq filename (expand-file-name "CBETA-to-UCS.txt" filename)))
 183   (with-temp-buffer
 184     (let ((i 1)
 185           chr ucs)
 186       (while (<= i 20000)
 187         (when (and (setq chr (decode-char 'ideograph-cbeta i))
 188                    (setq ucs (or (get-char-attribute chr 'ucs)
 189                                  (get-char-attribute chr '=>ucs))))
 190           (insert (format "CB%05d\t" i))
 191           (insert (format (if (<= ucs #xFFFF)
 192                               "U+%04X\n"
 193                             "U-%08X\n")
 194                           ucs)))
 195         (setq i (1+ i))))
 196     (write-region (point-min)(point-max) filename)))
 197
 198
 199 ;;; @ End.
 200 ;;;
 201
 202 (provide 'dump-tables)
 203
 204 ;;; dump-tables.el ends here