dump-tables.el

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