dump-tables.el

   1 ;;; dump-tables.el --- Dump utility of mapping tables
   2
   3 ;; Copyright (C) 2002,2003 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 (defun dump-94x94-ccs-to-ucs-table (filename default-file-name
  28                                              ccs ccs-prefix
  29                                              ucs-domain 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 (intern (format "=ucs@%s" ucs-domain)))
  34           (ucs-ccs-map (intern (format "=>ucs@%s" ucs-domain)))
  35           (ccs-format (concat ccs-prefix "%02X%02X"))
  36           (ucs-ccs-format (concat "\t" ucs-ccs-prefix "%04X\t"))
  37           (row 33)
  38           cell chr ucs ucs-l)
  39       (while (< row 127)
  40         (setq cell 33)
  41         (while (< cell 127)
  42           (when (and (setq chr (make-char ccs row cell))
  43                      (setq ucs (or (encode-char chr 'ucs 'defined-only)
  44                                    (get-char-attribute chr '=>ucs))))
  45             (setq ucs-l (or (encode-char chr ucs-ccs 'defined-only)
  46                             (get-char-attribute chr ucs-ccs-map)))
  47             (insert (format ccs-format row cell))
  48             (if (and ucs-l (/= ucs-l ucs))
  49                 (insert (format ucs-ccs-format ucs-l))
  50               (insert "\t "))
  51             (insert (format (if (<= ucs #xFFFF)
  52                                 "U+%04X\n"
  53                               "U-%08X\n")
  54                             ucs)))
  55           (setq cell (1+ cell)))
  56         (setq row (1+ row))))
  57     (write-region (point-min)(point-max) filename)))
  58
  59 ;;;###autoload
  60 (defun dump-jis-x0208-1990-to-ucs-table (filename)
  61   (interactive "Fdump J90-to-UCS : ")
  62   (dump-94x94-ccs-to-ucs-table
  63    filename "J90-to-UCS.txt"
  64    'japanese-jisx0208-1990 "J90-" 'jis "JU+"))
  65
  66 ;;;###autoload
  67 (defun dump-jis-x0212-to-ucs-table (filename)
  68   (interactive "Fdump JSP-to-UCS : ")
  69   (dump-94x94-ccs-to-ucs-table
  70    filename "JSP-to-UCS.txt"
  71    'japanese-jisx0212 "JSP-" 'jis "JU+"))
  72
  73 ;;;###autoload
  74 (defun dump-jis-x0213-1-to-ucs-table (filename)
  75   (interactive "Fdump JX1-to-UCS : ")
  76   (if (file-directory-p filename)
  77       (setq filename (expand-file-name "JX1-to-UCS.txt" filename)))
  78   (with-temp-buffer
  79     (let ((row 33)
  80           cell chr ucs ucs-j)
  81       (while (< row 127)
  82         (setq cell 33)
  83         (while (< cell 127)
  84           (when (and (setq chr (make-char 'japanese-jisx0213-1 row cell))
  85                      (not (encode-char chr 'japanese-jisx0208-1990
  86                                        'defined-only))
  87                      (setq ucs (or (encode-char chr 'ucs 'defined-only)
  88                                    (get-char-attribute chr '=>ucs))))
  89             (when (setq ucs-j
  90                         (or (encode-char chr '=ucs-jis-2000 'defined-only)
  91                             (get-char-attribute chr '=>ucs@jis)))
  92               (if (eq ucs-j ucs)
  93                   (setq ucs-j nil)))
  94             (insert (format "JX1-%02X%02X" row cell))
  95             (if ucs-j
  96                 (insert (format "\tJU+%04X\t" ucs-j))
  97               (insert "\t "))
  98             (insert (format (if (<= ucs #xFFFF)
  99                                 "U+%04X\n"
 100                               "U-%08X\n")
 101                             ucs)))
 102           (setq cell (1+ cell)))
 103         (setq row (1+ row))))
 104     (write-region (point-min)(point-max) filename)))
 105
 106 ;;;###autoload
 107 (defun dump-jis-x0213-2-to-ucs-table (filename)
 108   (interactive "Fdump JX2-to-UCS : ")
 109   (dump-94x94-ccs-to-ucs-table
 110    filename "JX2-to-UCS.txt"
 111    'japanese-jisx0213-2 "JX2-" 'jis "JU+"))
 112
 113 ;;;###autoload
 114 (defun dump-cns-11643-3-to-ucs-table (filename)
 115   (interactive "Fdump C3-to-UCS : ")
 116   (dump-94x94-ccs-to-ucs-table
 117    filename "C3-to-UCS.txt"
 118    'chinese-cns11643-3 "C3-" 'cns "CU+"))
 119
 120 ;;;###autoload
 121 (defun dump-cns-11643-4-to-ucs-table (filename)
 122   (interactive "Fdump C4-to-UCS : ")
 123   (dump-94x94-ccs-to-ucs-table
 124    filename "C4-to-UCS.txt"
 125    'chinese-cns11643-4 "C4-" 'cns "CU+"))
 126
 127 ;;;###autoload
 128 (defun dump-big5-to-ucs-table (filename)
 129   (interactive "Fdump B-to-UCS : ")
 130   (if (file-directory-p filename)
 131       (setq filename (expand-file-name "B-to-UCS.txt" filename)))
 132   (with-temp-buffer
 133     (let ((row #xA1)
 134           cell chr ucs ucs-big5)
 135       (while (<= row #xFE)
 136         (setq cell #x40)
 137         (while (< cell #xFE)
 138           (when (and (setq chr (make-char 'chinese-big5 row cell))
 139                      (setq ucs (or (encode-char chr 'ucs 'defined-only)
 140                                    (get-char-attribute chr '=>ucs))))
 141             (setq ucs-big5 (or (encode-char chr 'ucs-big5 'defined-only)
 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 (encode-char chr 'ucs 'defined-only)
 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 (encode-char chr 'ucs 'defined-only)
 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 ;;;###autoload
 199 (defun dump-jis2ucsdkw (filename)
 200   (interactive "Fdump jis2ucsdkw : ")
 201   (if (file-directory-p filename)
 202       (setq filename (expand-file-name "jis2ucsdkw.txt" filename)))
 203   (with-temp-buffer
 204     (let ((row 33)
 205           cell chr ucs-j md)
 206       (while (< row 127)
 207         (setq cell 33)
 208         (while (< cell 127)
 209           (when (and (setq chr (make-char 'japanese-jisx0213-1 row cell))
 210                      (setq ucs-j
 211                            (or (encode-char chr '=ucs@jis-2000 'defined-only)
 212                                (get-char-attribute chr '=>ucs@jis-2000)
 213                                (get-char-attribute chr '=>ucs@jis)
 214                                (get-char-attribute chr '=>ucs)))
 215                      (or (and (<= #x3400 ucs-j) (<= ucs-j #x9FA5))
 216                          (and (<= #xF900 ucs-j) (<= ucs-j #xFA6F))
 217                          (<= #x20000 ucs-j)))
 218             (insert (format "J1-%02d%02d" (- row 32)(- cell 32)))
 219             (if ucs-j
 220                 (insert (format " U+%05X" ucs-j))
 221               (insert "        "))
 222             (setq md (char-daikanwa chr))
 223             (cond ((integerp md)
 224                    (insert (format " D%05d.0\n" md)))
 225                   ((eq (car md) 'ho)
 226                    (insert (format " DHo%03d\n" (nth 1 md))))
 227                   (md
 228                    (insert (format " D%05d.%d\n" (car md)(nth 1 md))))
 229                   (t
 230                    (insert "\n")))
 231             )
 232           (setq cell (1+ cell)))
 233         (setq row (1+ row)))
 234       (setq row 33)
 235       (while (< row 127)
 236         (setq cell 33)
 237         (while (< cell 127)
 238           (when (and (setq chr (make-char 'japanese-jisx0213-2 row cell))
 239                      (setq ucs-j
 240                            (or (encode-char chr '=ucs@jis-2000 'defined-only)
 241                                (get-char-attribute chr '=>ucs@jis-2000)
 242                                (get-char-attribute chr '=>ucs@jis)
 243                                (get-char-attribute chr '=>ucs))))
 244             (insert (format "J2-%02d%02d" (- row 32)(- cell 32)))
 245             (if ucs-j
 246                 (insert (format " U+%05X" ucs-j))
 247               (insert "        "))
 248             (setq md (char-daikanwa chr))
 249             (cond ((integerp md)
 250                    (insert (format " D%05d.0\n" md)))
 251                   ((eq (car md) 'ho)
 252                    (insert (format " DHo%03d\n" (nth 1 md))))
 253                   (md
 254                    (insert (format " D%05d.%d\n" (car md)(nth 1 md))))
 255                   (t
 256                    (insert "\n")))
 257             )
 258           (setq cell (1+ cell)))
 259         (setq row (1+ row)))
 260       )
 261     (write-region (point-min)(point-max) filename)))
 262
 263
 264 ;;; @ End.
 265 ;;;
 266
 267 (provide 'dump-tables)
 268
 269 ;;; dump-tables.el ends here