Add/compact/modify/fix some IDSs.
[chise/ids.git] / ids-dump.el
1 ;;; ids-dump.el --- Dump utility of IDS-* files
2
3 ;; Copyright (C) 2002,2003 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-insert-line (ccs line-spec code)
30   (let ((chr (decode-char ccs code))
31         id-list)
32     (when chr
33       (setq id-list (get-char-attribute chr 'ideographic-structure))
34       (insert (format line-spec
35                       code (decode-builtin-char ccs code)
36                       (if id-list
37                           (ids-format-list id-list)
38                         (char-to-string chr)))))))
39
40 (defun ids-dump-insert-ccs-ranges (ccs line-spec &rest ranges)
41   (let (range code max-code)
42     (while ranges
43       (setq range (car ranges))
44       (cond ((consp range)
45              (setq code (car range)
46                    max-code (cdr range))
47              (while (<= code max-code)
48                (ids-dump-insert-line ccs line-spec code)
49                (setq code (1+ code))))
50             ((integerp range)
51              (ids-dump-insert-line ccs line-spec range))
52             (t (error 'wrong-type-argument range)))
53       (setq ranges (cdr ranges)))))
54
55 (defun ids-dump-insert-94x94-ccs-ranges (ccs line-spec &rest ranges)
56   (let (range code max-code l)
57     (while ranges
58       (setq range (car ranges))
59       (cond ((consp range)
60              (setq code (car range)
61                    max-code (cdr range))
62              (while (<= code max-code)
63                (setq l (logand code 255))
64                (if (and (<= #x21 l)(<= l #x7E))
65                    (ids-dump-insert-line ccs line-spec code))
66                (setq code (1+ code))))
67             ((integerp range)
68              (ids-dump-insert-line ccs line-spec range))
69             (t (error 'wrong-type-argument range)))
70       (setq ranges (cdr ranges)))))
71
72 (defun ids-dump-insert-daikanwa (start end)
73   (let ((i start)
74         mdh-alist
75         chr sal)
76     (map-char-attribute
77      (lambda (key val)
78        (when (= (length val) 2)
79          (set-alist 'mdh-alist
80                     (car val)
81                     (put-alist (nth 1 val)
82                                key
83                                (cdr (assq (car val) mdh-alist)))))
84        nil)
85      'morohashi-daikanwa)
86     (while (<= i end)
87       (when (setq chr (decode-char 'ideograph-daikanwa i))
88         (insert
89          (format "M-%05d \t%c\t%s\n"
90                  i (decode-builtin-char 'ideograph-daikanwa i)
91                  (or (ids-format-list
92                       (get-char-attribute chr 'ideographic-structure))
93                      ""))))
94       (when (setq sal (assq i mdh-alist))
95         (setq sal (cdr sal))
96         (when (setq chr (assq 1 sal))
97           (setq chr (cdr chr))
98           (insert
99            (format "M-%05d'\t%c\t%s\n"
100                    i chr
101                    (or (ids-format-list
102                         (get-char-attribute chr 'ideographic-structure))
103                        ""))))
104         (when (setq chr (assq 2 sal))
105           (setq chr (cdr chr))
106           (insert
107            (format "M-%05d\"\t%c\t%s\n"
108                    i chr
109                    (ids-format-list
110                     (get-char-attribute chr 'ideographic-structure)))))
111         )
112       (setq i (1+ i)))))
113
114 (defun ids-dump-insert-daikanwa-hokan ()
115   (let (chr sal)
116     (map-char-attribute
117      (lambda (key val)
118        (when (and (eq (car val) 'ho)
119                   (null (nthcdr 2 val)))
120          (setq sal (cons (cons (nth 1 val) key) sal)))
121        nil)
122      'morohashi-daikanwa)
123     (setq sal (sort sal (lambda (a b) (< (car a)(car b)))))
124     (dolist (cell sal)
125       (setq chr (cdr cell))
126       (insert
127        (format "MH-%04d \t%c\t%s\n"
128                (car cell)
129                chr
130                (or (ids-format-list
131                     (get-char-attribute chr 'ideographic-structure))
132                    ""))))))
133
134 (defun ids-dump-insert-jis-x0208-1990 ()
135   (let ((row 16)
136         cell h l code chr)
137     (while (<= row 83)
138       (setq h (+ row 32))
139       (setq cell 1)
140       (while (<= cell 94)
141         (setq l (+ cell 32))
142         (setq chr (make-char 'japanese-jisx0208-1990 h l))
143         (insert
144          (format "J90-%02X%02X\t%c\t%s\n"
145                  h l
146                  (decode-builtin-char 'japanese-jisx0208-1990
147                                       (logior (lsh h 8) l))
148                  (or (ids-format-list
149                       (get-char-attribute chr 'ideographic-structure))
150                      "")))
151         (setq cell (1+ cell)))
152       (setq row (1+ row)))
153     (setq h (+ row 32))
154     (setq cell 1)
155     (while (<= cell 6)
156       (setq l (+ cell 32))
157       (setq chr (make-char 'japanese-jisx0208-1990 h l))
158       (insert
159        (format "J90-%02X%02X\t%c\t%s\n"
160                h l
161                (decode-builtin-char 'japanese-jisx0208-1990
162                                     (logior (lsh h 8) l))
163                (or (ids-format-list
164                     (get-char-attribute chr 'ideographic-structure))
165                    "")))
166       (setq cell (1+ cell)))))
167
168 (defun ids-dump-insert-big5 (ccs prefix)
169   (let ((h #x81)
170         l code chr structure)
171     (while (<= h #xFE)
172       (setq l #x40)
173       (while (<= l #x7E)
174         (setq chr (make-char ccs h l))
175         (setq structure nil)
176         (when (setq structure
177                     (get-char-attribute chr 'ideographic-structure))
178           (insert
179            (format "%s%02X%02X\t%c\t%s\n"
180                    prefix h l
181                    (decode-builtin-char ccs
182                                         (logior (lsh h 8) l))
183                    (or (ids-format-list
184                         (get-char-attribute chr 'ideographic-structure))
185                        ""))))
186         (setq l (1+ l)))
187       (setq l #xA1)
188       (while (<= l #xFE)
189         (setq chr (make-char ccs h l))
190         (setq structure nil)
191         (when (setq structure
192                     (get-char-attribute chr 'ideographic-structure))
193           (insert
194            (format "%s%02X%02X\t%c\t%s\n"
195                    prefix h l
196                    (decode-builtin-char ccs
197                                         (logior (lsh h 8) l))
198                    (or (ids-format-list
199                         (get-char-attribute chr 'ideographic-structure))
200                        ""))))
201         (setq l (1+ l)))
202       (setq h (1+ h)))))
203
204 (defun ids-dump-insert-big5-pua (ccs prefix)
205   (let ((line-spec (concat prefix "%04X\t%c\t%s\n"))
206         (h #x81)
207         l)
208     (while (<= h #xA0)
209       (setq l #x40)
210       (while (<= l #x7E)
211         (ids-dump-insert-line ccs line-spec (logior (lsh h 8) l))
212         (setq l (1+ l)))
213       (setq l #xA1)
214       (while (<= l #xFE)
215         (ids-dump-insert-line ccs line-spec (logior (lsh h 8) l))
216         (setq l (1+ l)))
217       (setq h (1+ h)))
218     (setq h #xC6)
219     (setq l #xDE)
220     (while (<= l #xFE)
221       (ids-dump-insert-line ccs line-spec (logior (lsh h 8) l))
222       (setq l (1+ l)))
223     (setq h #xC7)
224     (while (<= h #xC8)
225       (setq l #x40)
226       (while (<= l #x7E)
227         (ids-dump-insert-line ccs line-spec (logior (lsh h 8) l))
228         (setq l (1+ l)))
229       (setq l #xA1)
230       (while (<= l #xFE)
231         (ids-dump-insert-line ccs line-spec (logior (lsh h 8) l))
232         (setq l (1+ l)))
233       (setq h (1+ h)))
234     (setq h #xFA)
235     (while (<= h #xFE)
236       (setq l #x40)
237       (while (<= l #x7E)
238         (ids-dump-insert-line ccs line-spec (logior (lsh h 8) l))
239         (setq l (1+ l)))
240       (setq l #xA1)
241       (while (<= l #xFE)
242         (ids-dump-insert-line ccs line-spec (logior (lsh h 8) l))
243         (setq l (1+ l)))
244       (setq h (1+ h)))))
245
246 (defun ids-dump-range (file path func &rest args)
247   (with-temp-buffer
248     (let* ((coding-system-for-write 'utf-8-mcs-er))
249       (if (file-directory-p path)
250           (setq path (expand-file-name file path)))
251       (insert ";; -*- coding: utf-8-mcs-er -*-\n")
252       (apply func args)
253       (write-region (point-min)(point-max) path))))
254
255 ;;;###autoload
256 (defun ids-dump-ucs-basic (filename)
257   (interactive "Fdump IDS-UCS-Basic : ")
258   (ids-dump-range "IDS-UCS-Basic.txt" filename
259                   #'ids-dump-insert-ccs-ranges 'ucs "U+%04X\t%c\t%s\n"
260                   '(#x4E00 . #x9FA5)))
261
262 ;;;###autoload
263 (defun ids-dump-ucs-ext-a (filename)
264   (interactive "Fdump IDS-UCS-Ext-A : ")
265   (ids-dump-range "IDS-UCS-Ext-A.txt" filename
266                   #'ids-dump-insert-ccs-ranges 'ucs "U+%04X\t%c\t%s\n"
267                   '(#x3400 . #x4DB5) #xFA1F #xFA23))
268
269 ;;;###autoload
270 (defun ids-dump-ucs-compat (filename)
271   (interactive "Fdump IDS-UCS-Compat : ")
272   (ids-dump-range "IDS-UCS-Compat.txt" filename
273                   #'ids-dump-insert-ccs-ranges 'ucs "U+%04X\t%c\t%s\n"
274                   '(#xF900 . #xFA1E) '(#xFA20 . #xFA22) '(#xFA24 . #xFA2D)))
275
276 ;;;###autoload
277 (defun ids-dump-ucs-ext-b-1 (filename)
278   (interactive "Fdump IDS-UCS-Ext-B-1 : ")
279   (ids-dump-range "IDS-UCS-Ext-B-1.txt" filename
280                   #'ids-dump-insert-ccs-ranges 'ucs "U-%08X\t%c\t%s\n"
281                   '(#x20000 . #x21FFF)))
282
283 ;;;###autoload
284 (defun ids-dump-ucs-ext-b-2 (filename)
285   (interactive "Fdump IDS-UCS-Ext-B-2 : ")
286   (ids-dump-range "IDS-UCS-Ext-B-2.txt" filename
287                   #'ids-dump-insert-ccs-ranges 'ucs "U-%08X\t%c\t%s\n"
288                   '(#x22000 . #x23FFF)))
289
290 ;;;###autoload
291 (defun ids-dump-ucs-ext-b-3 (filename)
292   (interactive "Fdump IDS-UCS-Ext-B-3 : ")
293   (ids-dump-range "IDS-UCS-Ext-B-3.txt" filename
294                   #'ids-dump-insert-ccs-ranges 'ucs "U-%08X\t%c\t%s\n"
295                   '(#x24000 . #x25FFF)))
296
297 ;;;###autoload
298 (defun ids-dump-ucs-ext-b-4 (filename)
299   (interactive "Fdump IDS-UCS-Ext-B-4 : ")
300   (ids-dump-range "IDS-UCS-Ext-B-4.txt" filename
301                   #'ids-dump-insert-ccs-ranges 'ucs "U-%08X\t%c\t%s\n"
302                   '(#x26000 . #x27FFF)))
303
304 ;;;###autoload
305 (defun ids-dump-ucs-ext-b-5 (filename)
306   (interactive "Fdump IDS-UCS-Ext-B-5 : ")
307   (ids-dump-range "IDS-UCS-Ext-B-5.txt" filename
308                   #'ids-dump-insert-ccs-ranges 'ucs "U-%08X\t%c\t%s\n"
309                   '(#x28000 . #x29FFF)))
310
311 ;;;###autoload
312 (defun ids-dump-ucs-ext-b-6 (filename)
313   (interactive "Fdump IDS-UCS-Ext-B-6 : ")
314   (ids-dump-range "IDS-UCS-Ext-B-6.txt" filename
315                   #'ids-dump-insert-ccs-ranges 'ucs "U-%08X\t%c\t%s\n"
316                   '(#x2A000 . #x2A6D6)))
317
318 ;;;###autoload
319 (defun ids-dump-ucs-compat-supplement (filename)
320   (interactive "Fdump IDS-UCS-Compat-Supplement : ")
321   (ids-dump-range "IDS-UCS-Compat-Supplement.txt" filename
322                   #'ids-dump-insert-ccs-ranges 'ucs "U-%08X\t%c\t%s\n"
323                   '(#x2F800 . #x2FA1D)))
324
325 ;;;###autoload
326 (defun ids-dump-cns11643-1 (filename)
327   (interactive "Fdump IDS-CNS-1 : ")
328   (ids-dump-range "IDS-CNS-1.txt" filename
329                   #'ids-dump-insert-94x94-ccs-ranges
330                   'chinese-cns11643-1 "C1-%04X\t%c\t%s\n"
331                   '(#x4421 . #x7D4B)))
332
333 ;;;###autoload
334 (defun ids-dump-cns11643-2 (filename)
335   (interactive "Fdump IDS-CNS-2 : ")
336   (ids-dump-range "IDS-CNS-2.txt" filename
337                   #'ids-dump-insert-94x94-ccs-ranges
338                   'chinese-cns11643-2 "C2-%04X\t%c\t%s\n"
339                   '(#x2121 . #x7244)))
340
341 ;;;###autoload
342 (defun ids-dump-cns11643-3 (filename)
343   (interactive "Fdump IDS-CNS-3 : ")
344   (ids-dump-range "IDS-CNS-3.txt" filename
345                   #'ids-dump-insert-94x94-ccs-ranges
346                   'chinese-cns11643-3 "C3-%04X\t%c\t%s\n"
347                   '(#x2121 . #x6246)))
348
349 ;;;###autoload
350 (defun ids-dump-daikanwa-01 (filename)
351   (interactive "Fdump IDS-Daikanwa-01 : ")
352   (ids-dump-range "IDS-Daikanwa-01.txt" filename
353                   #'ids-dump-insert-daikanwa 00001 01449))
354
355 ;;;###autoload
356 (defun ids-dump-daikanwa-02 (filename)
357   (interactive "Fdump IDS-Daikanwa-02 : ")
358   (ids-dump-range "IDS-Daikanwa-02.txt" filename
359                   #'ids-dump-insert-daikanwa 01450 04674))
360
361 ;;;###autoload
362 (defun ids-dump-daikanwa-03 (filename)
363   (interactive "Fdump IDS-Daikanwa-03 : ")
364   (ids-dump-range "IDS-Daikanwa-03.txt" filename
365                   #'ids-dump-insert-daikanwa 04675 07410))
366
367 ;;;###autoload
368 (defun ids-dump-daikanwa-04 (filename)
369   (interactive "Fdump IDS-Daikanwa-04 : ")
370   (ids-dump-range "IDS-Daikanwa-04.txt" filename
371                   #'ids-dump-insert-daikanwa 07411 11529))
372
373 ;;;###autoload
374 (defun ids-dump-daikanwa-05 (filename)
375   (interactive "Fdump IDS-Daikanwa-05 : ")
376   (ids-dump-range "IDS-Daikanwa-05.txt" filename
377                   #'ids-dump-insert-daikanwa 11530 14414))
378
379 ;;;###autoload
380 (defun ids-dump-daikanwa-06 (filename)
381   (interactive "Fdump IDS-Daikanwa-06 : ")
382   (ids-dump-range "IDS-Daikanwa-06.txt" filename
383                   #'ids-dump-insert-daikanwa 14415 17574))
384
385 ;;;###autoload
386 (defun ids-dump-daikanwa-07 (filename)
387   (interactive "Fdump IDS-Daikanwa-07 : ")
388   (ids-dump-range "IDS-Daikanwa-07.txt" filename
389                   #'ids-dump-insert-daikanwa 17575 22677))
390
391 ;;;###autoload
392 (defun ids-dump-daikanwa-08 (filename)
393   (interactive "Fdump IDS-Daikanwa-08 : ")
394   (ids-dump-range "IDS-Daikanwa-08.txt" filename
395                   #'ids-dump-insert-daikanwa 22678 28107))
396
397 ;;;###autoload
398 (defun ids-dump-daikanwa-09 (filename)
399   (interactive "Fdump IDS-Daikanwa-09 : ")
400   (ids-dump-range "IDS-Daikanwa-09.txt" filename
401                   #'ids-dump-insert-daikanwa 28108 32803))
402
403 ;;;###autoload
404 (defun ids-dump-daikanwa-10 (filename)
405   (interactive "Fdump IDS-Daikanwa-10 : ")
406   (ids-dump-range "IDS-Daikanwa-10.txt" filename
407                   #'ids-dump-insert-daikanwa 32804 38699))
408
409 ;;;###autoload
410 (defun ids-dump-daikanwa-11 (filename)
411   (interactive "Fdump IDS-Daikanwa-11 : ")
412   (ids-dump-range "IDS-Daikanwa-11.txt" filename
413                   #'ids-dump-insert-daikanwa 38700 42209))
414
415 ;;;###autoload
416 (defun ids-dump-daikanwa-12 (filename)
417   (interactive "Fdump IDS-Daikanwa-12 : ")
418   (ids-dump-range "IDS-Daikanwa-12.txt" filename
419                   #'ids-dump-insert-daikanwa 42210 48902))
420
421 ;;;###autoload
422 (defun ids-dump-daikanwa-index (filename)
423   (interactive "Fdump IDS-Daikanwa-dx : ")
424   (ids-dump-range "IDS-Daikanwa-dx.txt" filename
425                   #'ids-dump-insert-daikanwa 48903 49964))
426
427 ;;;###autoload
428 (defun ids-dump-daikanwa-hokan (filename)
429   (interactive "Fdump IDS-Daikanwa-ho : ")
430   (ids-dump-range "IDS-Daikanwa-ho.txt" filename
431                   #'ids-dump-insert-daikanwa-hokan))
432
433 ;;;###autoload
434 (defun ids-dump-cbeta (filename)
435   (interactive "Fdump IDS-CBETA : ")
436   (ids-dump-range "IDS-CBETA.txt" filename
437                   #'ids-dump-insert-ccs-ranges
438                   'ideograph-cbeta "CB%05d\t%c\t%s\n"
439                   '(1 . 13363)))
440
441 ;;;###autoload
442 (defun ids-dump-jis-x0208-1990 (filename)
443   (interactive "Fdump IDS-JIS-X0208-1990 : ")
444   (ids-dump-range "IDS-JIS-X0208-1990.txt" filename
445                   #'ids-dump-insert-jis-x0208-1990))
446
447 ;;;###autoload
448 (defun ids-dump-big5-cdp (filename)
449   (interactive "Fdump IDS-CDP : ")
450   (ids-dump-range "IDS-CDP.txt" filename
451                   #'ids-dump-insert-big5-pua
452                   '=big5-cdp "CDP-"))
453
454     
455 ;;; @ End.
456 ;;;
457
458 (provide 'ids-dump)
459
460 ;;; ids-dump.el ends here