dump-tables.el

   1 ;;; dump-tables.el --- Dump utility of mapping tables
   2
   3 ;; Copyright (C) 2002,2003,2004 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                                    (char-feature chr '=>ucs))))
  45             (setq ucs-l (or (encode-char chr ucs-ccs 'defined-only)
  46                             (char-feature 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-1-to-ucs-table (filename)
 115   (interactive "Fdump C1-to-UCS : ")
 116   (dump-94x94-ccs-to-ucs-table
 117    filename "C1-to-UCS.txt"
 118    'chinese-cns11643-1 "C1-" 'cns "CU+"))
 119
 120 ;;;###autoload
 121 (defun dump-cns-11643-2-to-ucs-table (filename)
 122   (interactive "Fdump C2-to-UCS : ")
 123   (dump-94x94-ccs-to-ucs-table
 124    filename "C2-to-UCS.txt"
 125    'chinese-cns11643-2 "C2-" 'cns "CU+"))
 126
 127 ;;;###autoload
 128 (defun dump-cns-11643-3-to-ucs-table (filename)
 129   (interactive "Fdump C3-to-UCS : ")
 130   (dump-94x94-ccs-to-ucs-table
 131    filename "C3-to-UCS.txt"
 132    'chinese-cns11643-3 "C3-" 'cns "CU+"))
 133
 134 ;;;###autoload
 135 (defun dump-cns-11643-4-to-ucs-table (filename)
 136   (interactive "Fdump C4-to-UCS : ")
 137   (dump-94x94-ccs-to-ucs-table
 138    filename "C4-to-UCS.txt"
 139    'chinese-cns11643-4 "C4-" 'cns "CU+"))
 140
 141 ;;;###autoload
 142 (defun dump-big5-to-ucs-table (filename)
 143   (interactive "Fdump B-to-UCS : ")
 144   (if (file-directory-p filename)
 145       (setq filename (expand-file-name "B-to-UCS.txt" filename)))
 146   (with-temp-buffer
 147     (let ((row #xA1)
 148           cell chr ucs ucs-big5)
 149       (while (<= row #xFE)
 150         (setq cell #x40)
 151         (while (< cell #xFE)
 152           (when (and (setq chr (make-char 'chinese-big5 row cell))
 153                      (setq ucs (or (encode-char chr 'ucs 'defined-only)
 154                                    (get-char-attribute chr '=>ucs))))
 155             (setq ucs-big5 (or (encode-char chr 'ucs-big5 'defined-only)
 156                                (get-char-attribute chr '=>ucs@big5)))
 157             (insert (format "B-%02X%02X" row cell))
 158             (if ucs-big5
 159                 (insert (format "\tBU+%04X\t" ucs-big5))
 160               (insert "\t "))
 161             (insert (format (if (<= ucs #xFFFF)
 162                                 "U+%04X\n"
 163                               "U-%08X\n")
 164                             ucs)))
 165           (setq cell (1+ cell)))
 166         (setq row (1+ row))))
 167     (write-region (point-min)(point-max) filename)))
 168
 169 ;;;###autoload
 170 (defun dump-jef-china3-to-ucs-table (filename)
 171   (interactive "Fdump JC3-to-UCS : ")
 172   (if (file-directory-p filename)
 173       (setq filename (expand-file-name "JC3-to-UCS.txt" filename)))
 174   (with-temp-buffer
 175     (let ((row #x41)
 176           cell chr ucs)
 177       (while (<= row #x9F)
 178         (setq cell #xA1)
 179         (while (<= cell #xFE)
 180           (when (and (setq chr (make-char 'china3-jef row cell))
 181                      (setq ucs (or (encode-char chr 'ucs 'defined-only)
 182                                    (get-char-attribute chr '=>ucs))))
 183             (insert (format "JC3-%02X%02X\t" row cell))
 184             (insert (format (if (<= ucs #xFFFF)
 185                                 "U+%04X\n"
 186                               "U-%08X\n")
 187                             ucs)))
 188           (setq cell (1+ cell)))
 189         (setq row (1+ row))))
 190     (write-region (point-min)(point-max) filename)))
 191
 192 ;;;###autoload
 193 (defun dump-cbeta-to-ucs-table (filename)
 194   (interactive "Fdump CBETA-to-UCS : ")
 195   (if (file-directory-p filename)
 196       (setq filename (expand-file-name "CBETA-to-UCS.txt" filename)))
 197   (with-temp-buffer
 198     (let ((i 1)
 199           chr ucs)
 200       (while (<= i 20000)
 201         (when (and (setq chr (decode-char 'ideograph-cbeta i))
 202                    (setq ucs (or (encode-char chr 'ucs 'defined-only)
 203                                  (get-char-attribute chr '=>ucs))))
 204           (insert (format "CB%05d\t" i))
 205           (insert (format (if (<= ucs #xFFFF)
 206                               "U+%04X\n"
 207                             "U-%08X\n")
 208                           ucs)))
 209         (setq i (1+ i))))
 210     (write-region (point-min)(point-max) filename)))
 211
 212 ;;;###autoload
 213 (defun dump-jis2ucsdkw (filename)
 214   (interactive "Fdump jis2ucsdkw : ")
 215   (if (file-directory-p filename)
 216       (setq filename (expand-file-name "jis2ucsdkw.txt" filename)))
 217   (with-temp-buffer
 218     (let ((row 33)
 219           cell chr ucs-j md)
 220       (while (< row 127)
 221         (setq cell 33)
 222         (while (< cell 127)
 223           (when (and (setq chr (make-char 'japanese-jisx0213-1 row cell))
 224                      (setq ucs-j
 225                            (or (encode-char chr '=ucs@jis-2000 'defined-only)
 226                                (get-char-attribute chr '=>ucs@jis-2000)
 227                                (get-char-attribute chr '=>ucs@jis)
 228                                (get-char-attribute chr '=>ucs)))
 229                      (or (and (<= #x3400 ucs-j) (<= ucs-j #x9FA5))
 230                          (and (<= #xF900 ucs-j) (<= ucs-j #xFA6F))
 231                          (<= #x20000 ucs-j)))
 232             (insert (format "J1-%02d%02d" (- row 32)(- cell 32)))
 233             (if ucs-j
 234                 (insert (format " U+%05X" ucs-j))
 235               (insert "        "))
 236             (setq md (char-daikanwa chr))
 237             (cond ((integerp md)
 238                    (insert (format " D%05d.0\n" md)))
 239                   ((eq (car md) 'ho)
 240                    (insert (format " DHo%03d\n" (nth 1 md))))
 241                   (md
 242                    (insert (format " D%05d.%d\n" (car md)(nth 1 md))))
 243                   (t
 244                    (insert "\n")))
 245             )
 246           (setq cell (1+ cell)))
 247         (setq row (1+ row)))
 248       (setq row 33)
 249       (while (< row 127)
 250         (setq cell 33)
 251         (while (< cell 127)
 252           (when (and (setq chr (make-char 'japanese-jisx0213-2 row cell))
 253                      (setq ucs-j
 254                            (or (encode-char chr '=ucs@jis-2000 'defined-only)
 255                                (get-char-attribute chr '=>ucs@jis-2000)
 256                                (get-char-attribute chr '=>ucs@jis)
 257                                (get-char-attribute chr '=>ucs))))
 258             (insert (format "J2-%02d%02d" (- row 32)(- cell 32)))
 259             (if ucs-j
 260                 (insert (format " U+%05X" ucs-j))
 261               (insert "        "))
 262             (setq md (char-daikanwa chr))
 263             (cond ((integerp md)
 264                    (insert (format " D%05d.0\n" md)))
 265                   ((eq (car md) 'ho)
 266                    (insert (format " DHo%03d\n" (nth 1 md))))
 267                   (md
 268                    (insert (format " D%05d.%d\n" (car md)(nth 1 md))))
 269                   (t
 270                    (insert "\n")))
 271             )
 272           (setq cell (1+ cell)))
 273         (setq row (1+ row)))
 274       )
 275     (write-region (point-min)(point-max) filename)))
 276
 277
 278 ;;; @ End.
 279 ;;;
 280
 281 (provide 'dump-tables)
 282
 283 ;;; dump-tables.el ends here