Revision: miles@gnu.org--gnu-2005/emacs--unicode--0--patch-68
[bpt/emacs.git] / lisp / international / ja-dic-cnv.el
1 ;;; ja-dic-cnv.el --- convert a Japanese dictionary (SKK-JISYO.L) to Emacs Lisp
2
3 ;; Copyright (C) 1995, 2000
4 ;; National Institute of Advanced Industrial Science and Technology (AIST)
5 ;; Registration Number H14PRO021
6
7 ;; Keywords: mule, multilingual, Japanese
8
9 ;; This file is part of GNU Emacs.
10
11 ;; GNU Emacs is free software; you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation; either version 2, or (at your option)
14 ;; any later version.
15
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
20
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
24 ;; Boston, MA 02110-1301, USA.
25
26 ;;; Commentary:
27
28 ;; SKK is a Japanese input method running on Mule created by Masahiko
29 ;; Sato <masahiko@sato.riec.tohoku.ac.jp>. Here we provide utilities
30 ;; to handle a dictionary distributed with SKK so that a different
31 ;; input method (e.g. quail-japanese) can utilize the dictionary.
32
33 ;; The format of SKK dictionary is quite simple. Each line has the
34 ;; form "KANASTRING /CONV1/CONV2/.../" which means KANASTRING (\e$B2>L>J8\e(B
35 ;; \e$B;zNs\e(B) can be converted to one of CONVi. CONVi is a Kanji (\e$B4A;z\e(B)
36 ;; and Kana (\e$B2>L>\e(B) mixed string.
37 ;;
38 ;; KANASTRING may have a trailing ASCII letter for Okurigana (\e$BAw$j2>L>\e(B)
39 ;; information. For instance, the trailing letter `k' means that one
40 ;; of the following Okurigana is allowed: \e$B$+$-$/$1$3\e(B. So, in that
41 ;; case, the string "KANASTRING\e$B$/\e(B" can be converted to one of "CONV1\e$B$/\e(B",
42 ;; CONV2\e$B$/\e(B, ...
43
44 ;;; Code:
45
46 ;; Name of a file to generate from SKK dictionary.
47 (defvar ja-dic-filename "ja-dic.el")
48
49 ;; To make a generated ja-dic.el smaller.
50 (define-coding-system 'iso-2022-7bit-short
51 "Like `iso-2022-7bit' but no ASCII designation before SPC."
52 :coding-type 'iso-2022
53 :mnemonic ?J
54 :charset-list 'iso-2022
55 :designation [(ascii t) nil nil nil]
56 :flags '(short 7-bit designation))
57
58 (defun skkdic-convert-okuri-ari (skkbuf buf)
59 (message "Processing OKURI-ARI entries ...")
60 (goto-char (point-min))
61 (save-excursion
62 (set-buffer buf)
63 (insert ";; Setting okuri-ari entries.\n"
64 "(skkdic-set-okuri-ari\n"))
65 (while (not (eobp))
66 (let ((from (point))
67 to)
68 (end-of-line)
69 (setq to (point))
70
71 (save-excursion
72 (set-buffer buf)
73 (insert-buffer-substring skkbuf from to)
74 (beginning-of-line)
75 (insert "\"")
76 (search-forward " ")
77 (delete-char 1) ; delete the first '/'
78 (let ((p (point)))
79 (end-of-line)
80 (delete-char -1) ; delete the last '/'
81 (subst-char-in-region p (point) ?/ ? 'noundo))
82 (insert "\"\n"))
83
84 (forward-line 1)))
85 (save-excursion
86 (set-buffer buf)
87 (insert ")\n\n")))
88
89 (defconst skkdic-postfix-list '(skkdic-postfix-list))
90
91 (defconst skkdic-postfix-data
92 '(("\e$B$$$-\e(B" "\e$B9T\e(B")
93 ("\e$B$,$+$j\e(B" "\e$B78\e(B")
94 ("\e$B$,$/\e(B" "\e$B3X\e(B")
95 ("\e$B$,$o\e(B" "\e$B@n\e(B")
96 ("\e$B$7$c\e(B" "\e$B<R\e(B")
97 ("\e$B$7$e$&\e(B" "\e$B=8\e(B")
98 ("\e$B$7$g$&\e(B" "\e$B>^\e(B" "\e$B>k\e(B")
99 ("\e$B$8$g$&\e(B" "\e$B>k\e(B")
100 ("\e$B$;$s\e(B" "\e$B@~\e(B")
101 ("\e$B$@$1\e(B" "\e$B3Y\e(B")
102 ("\e$B$A$c$/\e(B" "\e$BCe\e(B")
103 ("\e$B$F$s\e(B" "\e$BE9\e(B")
104 ("\e$B$H$&$2\e(B" "\e$BF=\e(B")
105 ("\e$B$I$*$j\e(B" "\e$BDL$j\e(B")
106 ("\e$B$d$^\e(B" "\e$B;3\e(B")
107 ("\e$B$P$7\e(B" "\e$B66\e(B")
108 ("\e$B$O$D\e(B" "\e$BH/\e(B")
109 ("\e$B$b$/\e(B" "\e$BL\\e(B")
110 ("\e$B$f$-\e(B" "\e$B9T\e(B")))
111
112 (defun skkdic-convert-postfix (skkbuf buf)
113 (message "Processing POSTFIX entries ...")
114 (goto-char (point-min))
115 (save-excursion
116 (set-buffer buf)
117 (insert ";; Setting postfix entries.\n"
118 "(skkdic-set-postfix\n"))
119
120 ;; Initialize SKKDIC-POSTFIX-LIST by predefined data
121 ;; SKKDIC-POSTFIX-DATA.
122 (save-excursion
123 (set-buffer buf)
124 (let ((l skkdic-postfix-data)
125 kana candidates entry)
126 (while l
127 (setq kana (car (car l)) candidates (cdr (car l)))
128 (insert "\"" kana)
129 (while candidates
130 (insert " " (car candidates))
131 (setq entry (lookup-nested-alist (car candidates)
132 skkdic-postfix-list nil nil t))
133 (if (consp (car entry))
134 (setcar entry (cons kana (car entry)))
135 (set-nested-alist (car candidates) (list kana)
136 skkdic-postfix-list))
137 (setq candidates (cdr candidates)))
138 (insert "\"\n")
139 (setq l (cdr l)))))
140
141 ;; Search postfix entries.
142 (while (re-search-forward "^[#<>?]\\(\\(\\cH\\|\e$B!<\e(B\\)+\\) " nil t)
143 (let ((kana (match-string 1))
144 str candidates)
145 (while (looking-at "/[#0-9 ]*\\([^/\n]*\\)/")
146 (setq str (match-string 1))
147 (if (not (member str candidates))
148 (setq candidates (cons str candidates)))
149 (goto-char (match-end 1)))
150 (save-excursion
151 (set-buffer buf)
152 (insert "\"" kana)
153 (while candidates
154 (insert " " (car candidates))
155 (let ((entry (lookup-nested-alist (car candidates)
156 skkdic-postfix-list nil nil t)))
157 (if (consp (car entry))
158 (if (not (member kana (car entry)))
159 (setcar entry (cons kana (car entry))))
160 (set-nested-alist (car candidates) (list kana)
161 skkdic-postfix-list)))
162 (setq candidates (cdr candidates)))
163 (insert "\"\n"))))
164 (save-excursion
165 (set-buffer buf)
166 (insert ")\n\n")))
167
168 (defconst skkdic-prefix-list '(skkdic-prefix-list))
169
170 (defun skkdic-convert-prefix (skkbuf buf)
171 (message "Processing PREFIX entries ...")
172 (goto-char (point-min))
173 (save-excursion
174 (set-buffer buf)
175 (insert ";; Setting prefix entries.\n"
176 "(skkdic-set-prefix\n"))
177 (save-excursion
178 (while (re-search-forward "^\\(\\(\\cH\\|\e$B!<\e(B\\)+\\)[<>?] " nil t)
179 (let ((kana (match-string 1))
180 str candidates)
181 (while (looking-at "/\\([^/\n]+\\)/")
182 (setq str (match-string 1))
183 (if (not (member str candidates))
184 (setq candidates (cons str candidates)))
185 (goto-char (match-end 1)))
186 (save-excursion
187 (set-buffer buf)
188 (insert "\"" kana)
189 (while candidates
190 (insert " " (car candidates))
191 (set-nested-alist (car candidates) kana skkdic-prefix-list)
192 (setq candidates (cdr candidates)))
193 (insert "\"\n")))))
194 (save-excursion
195 (set-buffer buf)
196 (insert ")\n\n")))
197
198 ;; FROM and TO point the head and tail of "/J../J../.../".
199 (defun skkdic-get-candidate-list (from to)
200 (let (candidates)
201 (goto-char from)
202 (while (re-search-forward "/[^/ \n]+" to t)
203 (setq candidates (cons (buffer-substring (1+ (match-beginning 0))
204 (match-end 0))
205 candidates)))
206 candidates))
207
208 ;; Return entry for STR from nested alist ALIST.
209 (defsubst skkdic-get-entry (str alist)
210 (car (lookup-nested-alist str alist nil nil t)))
211
212
213 (defconst skkdic-word-list '(skkdic-word-list))
214
215 ;; Return t if substring of STR (between FROM and TO) can be broken up
216 ;; to chunks all of which can be derived from another entry in SKK
217 ;; dictionary. SKKBUF is the buffer where the original SKK dictionary
218 ;; is visited, KANA is the current entry for STR. FIRST is t iff this
219 ;; is called at top level.
220
221 (defun skkdic-breakup-string (skkbuf kana str from to &optional first)
222 (let ((len (- to from)))
223 (or (and (>= len 2)
224 (let ((min-idx (+ from 2))
225 (idx (if first (1- to ) to))
226 (found nil))
227 (while (and (not found) (>= idx min-idx))
228 (let ((kana2-list (skkdic-get-entry
229 (substring str from idx)
230 skkdic-word-list)))
231 (if (or (and (consp kana2-list)
232 (let ((kana-len (length kana))
233 kana2)
234 (catch 'skkdic-tag
235 (while kana2-list
236 (setq kana2 (car kana2-list))
237 (if (string-match kana2 kana)
238 (throw 'skkdic-tag t))
239 (setq kana2-list (cdr kana2-list)))))
240 (or (= idx to)
241 (skkdic-breakup-string skkbuf kana str
242 idx to)))
243 (and (stringp kana2-list)
244 (string-match kana2-list kana)))
245 (setq found t)
246 (setq idx (1- idx)))))
247 found))
248 (and first
249 (> len 2)
250 (let ((kana2 (skkdic-get-entry
251 (substring str from (1+ from))
252 skkdic-prefix-list)))
253 (and (stringp kana2)
254 (eq (string-match kana2 kana) 0)))
255 (skkdic-breakup-string skkbuf kana str (1+ from) to))
256 (and (not first)
257 (>= len 1)
258 (let ((kana2-list (skkdic-get-entry
259 (substring str from to)
260 skkdic-postfix-list)))
261 (and (consp kana2-list)
262 (let (kana2)
263 (catch 'skkdic-tag
264 (while kana2-list
265 (setq kana2 (car kana2-list))
266 (if (string= kana2
267 (substring kana (- (length kana2))))
268 (throw 'skkdic-tag t))
269 (setq kana2-list (cdr kana2-list)))))))))))
270
271 ;; Return list of candidates which excludes some from CANDIDATES.
272 ;; Excluded candidates can be derived from another entry.
273
274 (defun skkdic-reduced-candidates (skkbuf kana candidates)
275 (let (elt l)
276 (while candidates
277 (setq elt (car candidates))
278 (if (or (= (length elt) 1)
279 (and (string-match "^\\cj" elt)
280 (not (skkdic-breakup-string skkbuf kana elt 0 (length elt)
281 'first))))
282 (setq l (cons elt l)))
283 (setq candidates (cdr candidates)))
284 (nreverse l)))
285
286 (defvar skkdic-okuri-nasi-entries (list nil))
287 (defvar skkdic-okuri-nasi-entries-count 0)
288
289 (defun skkdic-collect-okuri-nasi ()
290 (message "Collecting OKURI-NASI entries ...")
291 (save-excursion
292 (let ((prev-ratio 0)
293 ratio)
294 (while (re-search-forward "^\\(\\(\\cH\\|\e$B!<\e(B\\)+\\) \\(/\\cj.*\\)/$"
295 nil t)
296 (let ((kana (match-string 1))
297 (candidates (skkdic-get-candidate-list (match-beginning 3)
298 (match-end 3))))
299 (setq skkdic-okuri-nasi-entries
300 (cons (cons kana candidates) skkdic-okuri-nasi-entries)
301 skkdic-okuri-nasi-entries-count
302 (1+ skkdic-okuri-nasi-entries-count))
303 (setq ratio (floor (/ (* (point) 100.0) (point-max))))
304 (if (/= ratio prev-ratio)
305 (progn
306 (message "collected %2d%% %s ..." ratio kana)
307 (setq prev-ratio ratio)))
308 (while candidates
309 (let ((entry (lookup-nested-alist (car candidates)
310 skkdic-word-list nil nil t)))
311 (if (consp (car entry))
312 (setcar entry (cons kana (car entry)))
313 (set-nested-alist (car candidates) (list kana)
314 skkdic-word-list)))
315 (setq candidates (cdr candidates))))))))
316
317 (defun skkdic-convert-okuri-nasi (skkbuf buf)
318 (message "Processing OKURI-NASI entries ...")
319 (save-excursion
320 (set-buffer buf)
321 (insert ";; Setting okuri-nasi entries.\n"
322 "(skkdic-set-okuri-nasi\n")
323 (let ((l (nreverse skkdic-okuri-nasi-entries))
324 (count 0)
325 (prev-ratio 0)
326 ratio)
327 (while l
328 (let ((kana (car (car l)))
329 (candidates (cdr (car l))))
330 (setq ratio (/ (* count 1000) skkdic-okuri-nasi-entries-count)
331 count (1+ count))
332 (if (/= prev-ratio (/ ratio 10))
333 (progn
334 (message "processed %2d%% %s ..." (/ ratio 10) kana)
335 (setq prev-ratio (/ ratio 10))))
336 (if (setq candidates
337 (skkdic-reduced-candidates skkbuf kana candidates))
338 (progn
339 (insert "\"" kana)
340 (while candidates
341 (insert " " (car candidates))
342 (setq candidates (cdr candidates)))
343 (insert "\"\n"))))
344 (setq l (cdr l))))
345 (insert ")\n\n")))
346
347 (defun skkdic-convert (filename &optional dirname)
348 "Generate Emacs lisp file form Japanese dictionary file FILENAME.
349 The format of the dictionary file should be the same as SKK dictionaries.
350 Optional argument DIRNAME if specified is the directory name under which
351 the generated Emacs Lisp is saved.
352 The name of generated file is specified by the variable `ja-dic-filename'."
353 (interactive "FSKK dictionary file: ")
354 (message "Reading file \"%s\" ..." filename)
355 (let* ((coding-system-for-read 'euc-japan)
356 (skkbuf(find-file-noselect (expand-file-name filename)))
357 (buf (get-buffer-create "*skkdic-work*")))
358 (save-excursion
359 ;; Setup and generate the header part of working buffer.
360 (set-buffer buf)
361 (erase-buffer)
362 (buffer-disable-undo)
363 (insert ";;; ja-dic.el --- dictionary for Japanese input method"
364 " -*-coding: iso-2022-jp;-*-\n"
365 ";;\tGenerated by the command `skkdic-convert'\n"
366 ";;\tDate: " (current-time-string) "\n"
367 ";;\tOriginal SKK dictionary file: "
368 (file-name-nondirectory filename)
369 "\n\n"
370 ";; This file is part of GNU Emacs.\n\n"
371 ";;; Commentary:\n\n"
372 ";; Do byte-compile this file again after any modification.\n\n"
373 ";;; Start of the header of the original SKK dictionary.\n\n")
374 (set-buffer skkbuf)
375 (widen)
376 (goto-char 1)
377 (let (pos)
378 (search-forward ";; okuri-ari")
379 (forward-line 1)
380 (setq pos (point))
381 (set-buffer buf)
382 (insert-buffer-substring skkbuf 1 pos))
383 (insert "\n"
384 ";;; Code:\n\n(eval-when-compile (require 'ja-dic-cnv))\n\n")
385
386 ;; Generate the body part of working buffer.
387 (set-buffer skkbuf)
388 (let ((from (point))
389 to)
390 ;; Convert okuri-ari entries.
391 (search-forward ";; okuri-nasi")
392 (beginning-of-line)
393 (setq to (point))
394 (narrow-to-region from to)
395 (skkdic-convert-okuri-ari skkbuf buf)
396 (widen)
397
398 ;; Convert okuri-nasi postfix entries.
399 (goto-char to)
400 (forward-line 1)
401 (setq from (point))
402 (re-search-forward "^\\cH")
403 (setq to (match-beginning 0))
404 (narrow-to-region from to)
405 (skkdic-convert-postfix skkbuf buf)
406 (widen)
407
408 ;; Convert okuri-nasi prefix entries.
409 (goto-char to)
410 (skkdic-convert-prefix skkbuf buf)
411
412 ;;
413 (skkdic-collect-okuri-nasi)
414
415 ;; Convert okuri-nasi general entries.
416 (skkdic-convert-okuri-nasi skkbuf buf)
417
418 ;; Postfix
419 (save-excursion
420 (set-buffer buf)
421 (goto-char (point-max))
422 (insert ";;\n(provide 'ja-dic)\n\n;;; ja-dic.el ends here\n")))
423
424 ;; Save the working buffer.
425 (set-buffer buf)
426 (set-visited-file-name (expand-file-name ja-dic-filename dirname) t)
427 (set-buffer-file-coding-system 'iso-2022-7bit-short)
428 (save-buffer 0))
429 (kill-buffer skkbuf)
430 (switch-to-buffer buf)))
431
432 (defun batch-skkdic-convert ()
433 "Run `skkdic-convert' on the files remaining on the command line.
434 Use this from the command line, with `-batch';
435 it won't work in an interactive Emacs.
436 For example, invoke:
437 % emacs -batch -l ja-dic-cnv -f batch-skkdic-convert SKK-JISYO.L
438 to generate \"ja-dic.el\" from SKK dictionary file \"SKK-JISYO.L\".
439 To get complete usage, invoke:
440 % emacs -batch -l ja-dic-cnv -f batch-skkdic-convert -h"
441 (defvar command-line-args-left) ; Avoid compiler warning.
442 (if (not noninteractive)
443 (error "`batch-skkdic-convert' should be used only with -batch"))
444 (if (string= (car command-line-args-left) "-h")
445 (progn
446 (message "To convert SKK-JISYO.L into skkdic.el:")
447 (message " %% emacs -batch -l ja-dic-cnv -f batch-skkdic-convert SKK-JISYO.L")
448 (message "To convert SKK-JISYO.L into DIR/ja-dic.el:")
449 (message " %% emacs -batch -l ja-dic-cnv -f batch-skkdic-convert -dir DIR SKK-JISYO.L"))
450 (let (targetdir filename)
451 (if (string= (car command-line-args-left) "-dir")
452 (progn
453 (setq command-line-args-left (cdr command-line-args-left))
454 (setq targetdir (expand-file-name (car command-line-args-left)))
455 (setq command-line-args-left (cdr command-line-args-left))))
456 (setq filename (expand-file-name (car command-line-args-left)))
457 (message "Converting %s to %s ..." filename ja-dic-filename)
458 (message "It takes around 10 minutes even on Sun SS20.")
459 (skkdic-convert filename targetdir)
460 (message "Do byte-compile the created file by:")
461 (message " %% emacs -batch -f batch-byte-compile %s" ja-dic-filename)
462 ))
463 (kill-emacs 0))
464
465
466 ;; The following macros are expanded at byte-compiling time so that
467 ;; compiled code can be loaded quickly.
468
469 (defun skkdic-get-kana-compact-codes (kana)
470 (let* ((len (length kana))
471 (vec (make-vector len 0))
472 (i 0)
473 ch)
474 (while (< i len)
475 (setq ch (aref kana i))
476 (aset vec i
477 (if (< ch 128) ; CH is an ASCII letter for OKURIGANA,
478 (- ch) ; represented by a negative code.
479 (if (= ch ?\e$B!<\e(B) ; `\e$B!<\e(B' is represented by 0.
480 0
481 (- (logand (encode-char ch 'japanese-jisx0208) #xFF) 32))))
482 (setq i (1+ i)))
483 vec))
484
485 (defun skkdic-extract-conversion-data (entry)
486 (string-match "^\\cj+[a-z]* " entry)
487 (let ((kana (substring entry (match-beginning 0) (1- (match-end 0))))
488 (i (match-end 0))
489 candidates)
490 (while (string-match "[^ ]+" entry i)
491 (setq candidates (cons (match-string 0 entry) candidates))
492 (setq i (match-end 0)))
493 (cons (skkdic-get-kana-compact-codes kana) candidates)))
494
495 (defmacro skkdic-set-okuri-ari (&rest entries)
496 `(defconst skkdic-okuri-ari
497 ',(let ((l entries)
498 (map '(skkdic-okuri-ari))
499 entry)
500 (while l
501 (setq entry (skkdic-extract-conversion-data (car l)))
502 (set-nested-alist (car entry) (cdr entry) map)
503 (setq l (cdr l)))
504 map)))
505
506 (defmacro skkdic-set-postfix (&rest entries)
507 `(defconst skkdic-postfix
508 ',(let ((l entries)
509 (map '(nil))
510 (longest 1)
511 len entry)
512 (while l
513 (setq entry (skkdic-extract-conversion-data (car l)))
514 (setq len (length (car entry)))
515 (if (> len longest)
516 (setq longest len))
517 (let ((entry2 (lookup-nested-alist (car entry) map nil nil t)))
518 (if (consp (car entry2))
519 (let ((conversions (cdr entry)))
520 (while conversions
521 (if (not (member (car conversions) (car entry2)))
522 (setcar entry2 (cons (car conversions) (car entry2))))
523 (setq conversions (cdr conversions))))
524 (set-nested-alist (car entry) (cdr entry) map)))
525 (setq l (cdr l)))
526 (setcar map longest)
527 map)))
528
529 (defmacro skkdic-set-prefix (&rest entries)
530 `(defconst skkdic-prefix
531 ',(let ((l entries)
532 (map '(nil))
533 (longest 1)
534 len entry)
535 (while l
536 (setq entry (skkdic-extract-conversion-data (car l)))
537 (setq len (length (car entry)))
538 (if (> len longest)
539 (setq longest len))
540 (let ((entry2 (lookup-nested-alist (car entry) map len nil t)))
541 (if (consp (car entry2))
542 (let ((conversions (cdr entry)))
543 (while conversions
544 (if (not (member (car conversions) (car entry2)))
545 (setcar entry2 (cons (car conversions) (car entry2))))
546 (setq conversions (cdr conversions))))
547 (set-nested-alist (car entry) (cdr entry) map len)))
548 (setq l (cdr l)))
549 (setcar map longest)
550 map)))
551
552 (defmacro skkdic-set-okuri-nasi (&rest entries)
553 `(defconst skkdic-okuri-nasi
554 ',(let ((l entries)
555 (map '(skdic-okuri-nasi))
556 (count 0)
557 entry)
558 (while l
559 (setq count (1+ count))
560 (if (= (% count 10000) 0)
561 (message (format "%d entries" count)))
562 (setq entry (skkdic-extract-conversion-data (car l)))
563 (set-nested-alist (car entry) (cdr entry) map)
564 (setq l (cdr l)))
565 map)))
566
567 (provide 'ja-dic-cnv)
568
569 ;; Local Variables:
570 ;; coding: iso-2022-7bit
571 ;; End:
572
573 ;;; arch-tag: dec06fb0-8118-45b1-80d7-dc360b6fd3b2
574 ;;; ja-dic-cnv.el ends here