root/lang/elisp/pdicv-mode/trunk/pdicv-core.el

Revision 76, 21.9 kB (checked in by naoya_t, 16 years ago)

pdicv-core.el: saved in utf-8

Line 
1;;; pdicv-core.el --- core functions for PDIC-formatted dictionaries
2;;
3;; Copyright (C) 2005-2009 naoya_t. All Rights Reserved.
4;;
5;; Author: naoya_t <naoya.t@aqua.plala.or.jp>
6;; Maintainer: naoya_t <naoya.t@aqua.plala.or.jp>
7;; Primary distribution site:
8;;   http://lambdarepos.svnrepository.com/svn/share/lang/elisp/pdicv-mode/trunk
9;;
10;; Created: 14 Feb 2005
11;; Last modified: 30 Jan 2009
12;; Version: 0.9.2
13;; Keywords: PDIC dictionary search eijiro
14
15(provide 'pdicv-core)
16;(put 'pdicv-core 'version "0.9.2")
17
18;;; Commentary:
19
20; (pdicv-get-header-info FILENAME)
21;    - ヘッダ情報を読み取る
22;
23; (pdicv-get-index-list FILENAME [WORD-ENCODING])
24;    - PDIC辞書ファイルから、インデックスリストを取得
25;
26; (pdicv-scan-datablock FILENAME PHYS CRITERIA-FUNC)
27;    - データブロックをスキャン
28;
29; (pdicv-core-search DICINFO CRITERIA [SIMPLE-MODE-P DONT-CLEAR-P])
30;    - PDIC検索(コアルーチン)
31;
32
33;;; Code:
34(require 'nt-macros)
35(require 'nt-readval)
36(require 'nt-string)
37(require 'nt-bocu)
38(require 'nt-file)
39(require 'nt-english)
40
41; decoder
42(defvar pdicv-null-decoder (lambda (s) s))
43(defvar pdicv-sjis-decoder (lambda (s) (decode-coding-string s 'japanese-shift-jis-dos)))
44(defvar pdicv-latin1-decoder (lambda (s) (decode-coding-string s 'iso-latin-1-dos)))
45(defvar pdicv-bocu-decoder (lambda (s) (nt:bocu-decode s)))
46(defmacro pdicv-create-decoder (encoding)
47  "create a decoder from user-specified encoding"
48  `(lambda (s) (decode-coding-string s ,encoding)))
49
50(defvar pdicv-index-table-list ())
51
52(defvar pdicv-result-height 8)
53;
54; ヘッダ情報を読み取る
55;
56(defun pdicv-get-header-info (filename)
57  "[PDIC] Get Header Info"
58  (catch 'pdicv-get-header-info
59    (let* ((header-buf (nt:read-from-file filename 0 256))
60           ;
61           (headername nil); (substring header-buf 1 100))
62           (dictitle nil); (substring header-buf 101 140))
63           (version (nt:read-short header-buf 140))
64           (lword (nt:read-short header-buf 142))
65           (ljapa (nt:read-short header-buf 144))
66           (block-size (nt:read-short header-buf 146))
67           (index-block (nt:read-short header-buf 148))
68           (header-size (nt:read-short header-buf 150))
69           (index-size (nt:read-ushort header-buf 152))
70           (empty-block (nt:read-short header-buf 154))
71           (nindex (nt:read-short header-buf 156))
72           (nblock (nt:read-short header-buf 158))
73           (nword (nt:read-ulong header-buf 160))
74           (dicorder (nt:read-uchar header-buf 164))
75           (dictype (nt:read-uchar header-buf 165)) (dictype* nil)
76           (attrlen (nt:read-uchar header-buf 166))
77                                        ; NEWDIC2-
78           (olenumber 0) (os nil)
79           (lid-word 0) (lid-japa 0) (lid-exp 0) (lid-pron 0) (lid-other 0)
80                                        ; NEWDIC3-
81           (extheader 0) (index-blkbit 0) (cypt nil) (update-count 0)
82           (dicident nil)
83           ;;
84           (major-version (/ version 256))
85           (datablock-size (* nblock block-size))
86           (bocu nil)
87           )
88
89      (setq version
90            (nth major-version '(not-supported not-supported newdic1 newdic2 newdic3 newdic4 unicode-bocu-6)))
91
92      (setq dicorder
93            (nth (nt:read-uchar header-buf 164) '(code-order ignore-case dictionary-order order-descendant)))
94
95      (when (> (logand dictype 128) 0) (setq dictype* (cons 'tree-view-mode dictype*)))
96      (when (> (logand dictype 64) 0) (setq dictype* (cons 'crypted dictype*)))
97;     (when (> (logand dictype 32) 0) (setq dictype* (cons 'multilingual dictype*)))
98      (when (> (logand dictype 16) 0) (setq dictype* (cons 'unicode dictype*)))
99      (when (> (logand dictype 8) 0) (setq dictype* (cons 'bocu dictype*)))
100      (when (> (logand dictype 1) 0) (setq dictype* (cons 'ar-compressed dictype*)))
101
102          ;;(case major-version
103          (cond
104           ((= major-version 6)
105                ;;(6 "Ver 6.xx"
106                   (setq os (nt:read-char header-buf 167))
107                   (setq os (cond ((= os 0) 'sjis-crlf)
108                                                  ((= os 1) 'sjis-cr)
109                                                  ((= os 2) 'sjis-lf)
110                                                  ((= os 3) 'euc-lf)
111                                                  ((= os 4) 'jis-lf)
112                                                  ((= os 32) 'bocu)
113                                                  ))
114                   (when (eq os 'bocu) (setq bocu t))
115                   (setq olenumber (nt:read-long header-buf 168))
116                   ;; dummy_lid, 10 bytes
117                   (setq index-blkbit (if (= (nt:read-uchar header-buf 182) 1) 32 16))
118                   ;; dummy0 @185
119                   (setq extheader (nt:read-ulong header-buf 184))
120                   (setq empty-block (nt:read-long header-buf 188)) ;overwrite
121                   (setq nindex (nt:read-long header-buf 192)) ;overwrite
122                   (setq nblock (nt:read-long header-buf 196)) ;overwrite
123                   (setq datablock-size (* nblock block-size))
124                   (setq cypt (substring header-buf 200 208)) ;- reserved[8]
125                   (setq update-count (nt:read-ulong header-buf 208))
126                                        ; dummy00 @212[4]
127                   (setq dicident (substring header-buf 216 224))
128                                        ;(setq dummy (substring header-buf 224 256))
129                   (setq index-size (* index-block block-size)) ;overwrite
130                   );6
131           ((= major-version 5)
132                ;;(5 "HyperDIC, Ver 5.00"
133                   (setq os (nt:read-char header-buf 167))
134                   (setq os (cond ((= os 0) 'sjis-crlf)
135                                                  ((= os 1) 'sjis-cr)
136                                                  ((= os 2) 'sjis-lf)
137                                                  ((= os 3) 'euc-lf)
138                                                  ((= os 4) 'jis-lf)
139                                                  ((= os 32) 'bocu)
140                                                  ))
141                   (when (eq os 'bocu) (setq bocu t))
142                   (setq olenumber (nt:read-long header-buf 168))
143                   (setq index-blkbit (if (= (nt:read-uchar header-buf 182) 1) 32 16))
144                   ;; dummy0 @185
145                   (setq extheader (nt:read-ulong header-buf 184))
146                   (setq empty-block (nt:read-long header-buf 188)) ;overwrite
147                   (setq nindex (nt:read-long header-buf 192)) ;overwrite
148                   (setq nblock (nt:read-long header-buf 196)) ;overwrite
149                   (setq datablock-size (* nblock block-size))
150                   (setq cypt (substring header-buf 200 208)) ;- reserved[8]
151                   (setq update-count (nt:read-ulong header-buf 208))
152                                        ; dummy00 @212[4]
153                   (setq dicident (substring header-buf 216 224))
154                                        ;(setq dummy (substring header-buf 224 256))
155                   (setq index-size (* index-block block-size)) ;overwrite
156                   );5
157           (t "< 5.0"
158                   (when (>= major-version 3)
159                         "NEWDIC2-"
160                         (setq olenumber (nt:read-long header-buf 167))
161                                        ;(setq os (byte (substring header-buf 172 173)))
162                         (setq os (nth (nt:read-char header-buf 171) '(sjis-crlf)))
163                                        ;(setq lid-word (short header-buf 172))
164                                        ;(setq lid-japa (short header-buf 174))
165                                        ;(setq lid-exp (short header-buf 176))
166                                        ;(setq lid-pron (short header-buf 178))
167                                        ;(setq lid-other (short header-buf 180))
168                         )
169                   (when (>= major-version 4)
170                         "NEWDIC3-"
171                         (setq extheader (nt:read-ulong header-buf 182))
172                         (setq empty-block (nt:read-long header-buf 186)) ;overwrite
173                         (setq nindex (nt:read-long header-buf 190)) ;overwrite
174                         (setq nblock (nt:read-long header-buf 194)) ;overwrite
175                         (setq datablock-size (* nblock block-size))
176                         (setq index-blkbit (if (= (nt:read-uchar header-buf 198) 1) 32 16))
177                         (setq cypt (substring header-buf 200 208))
178                         (setq update-count (nt:read-ulong header-buf 207))
179                                        ;(setq dummy (substring header-buf 212 256))
180                         (setq index-size (* index-block block-size)) ;overwrite
181                         )
182               )); esac
183      (list
184;       (cons 'headername headername)   ;
185;       (cons 'dictitle dictitle)       ;
186       (cons 'version version)         ;
187       (cons 'lword lword)             ;
188       (cons 'ljapa ljapa)             ;
189       (cons 'block-size block-size)   ;
190       (cons 'index-block index-block) ;
191       (cons 'header-size header-size) ;
192       (cons 'index-size index-size)   ;
193       (cons 'empty-block empty-block) ;
194       (cons 'nindex nindex)           ;
195       (cons 'nblock nblock)           ;
196       (cons 'nword nword)             ;
197       (cons 'dicorder dicorder)       ;
198       (cons 'dictype dictype*)        ;
199       (cons 'attrlen attrlen)         ;
200       (cons 'os os)                   ;
201                                        ;       (cons 'lid-word lid-word) ;
202                                        ;       (cons 'lid-japa lid-japa) ;
203                                        ;       (cons 'lid-exp lid-exp) ;
204                                        ;       (cons 'lid-pron lid-pron) ;
205                                        ;       (cons 'lid-other lid-other) ;
206       (cons 'extheader extheader) ;
207       (cons 'index-blkbit index-blkbit) ;(0=16,1=32)
208       (cons 'cypt cypt) ;
209       (cons 'update-count update-count) ;
210       
211       (cons 'index-begins-at (+ header-size extheader))
212       (cons 'datablock-begins-at (+ header-size extheader index-size))
213       (cons 'datablock-ends-at (+ header-size extheader index-size datablock-size))
214       (cons 'datablock-size datablock-size)
215       (cons 'bocu bocu)))))
216
217(defun pdicv-get-index-list (filename &optional word-encoding)
218  "[PDICV] Get the index list from PDIC file"
219  (let* ((header (pdicv-get-header-info filename))
220         (index-buf (nt:read-from-file filename
221                                    (-> header 'index-begins-at) (-> header 'index-size)))
222
223         (32bit-address-mode (if (= (-> header 'index-blkbit) 32) t nil))
224                 (tab-sep-p (eq 'unicode-bocu-6 (-> header 'version)))
225
226         (ix 0) (ix-max (-> header 'nindex))
227         (ofs 0)
228         (index-list ()))
229    (while (< ix ix-max)
230      (let ((phys -1) (word "") (word* nil))
231        (if 32bit-address-mode
232            (progn (setq phys (nt:read-ulong index-buf ofs))
233                                   (setq ofs (+ ofs 4)))
234          (progn (setq phys (nt:read-ushort index-buf ofs))
235                                 (setq ofs (+ ofs 2))))
236        (setq word* (nt:read-cstring index-buf ofs)) (setq ofs (+ ofs (cdr word*) 1))
237        (setq word (car word*))
238
239                (when tab-sep-p
240                  (let ((tsv (split-string word "\t")))
241                        (when (consp tsv)
242                          (setq word (car tsv)))))
243;       (cond
244;        ((eq word-encoding 'bocu)
245;         (setq word (nt:bocu-decode word)))
246;        ((eq word-encoding 'sjis)
247;         (setq word (decode-coding-string word 'japanese-shift-jis-dos)))
248;        (word-encoding
249;         (setq word (decode-coding-string word word-encoding)))
250;        (t nil))
251
252;       (setq index-list (cons (cons phys word) index-list))
253        (push (cons phys word) index-list)
254        (setq ix (1+ ix))
255        ))
256    (nreverse index-list) ))
257
258(defface pdicv-face-dummy
259  '((( (class color) (background light) )
260     (:foreground "green" :background "SlateGray1" :weight bold))
261    (t
262     (:foreground "red" :background "black"))) ; :weight bold
263    "Face for caption")
264(defface pdicv-face-caption-red
265  '((t (:foreground "red" :background "black")))
266  "Face for caption")
267(defface pdicv-face-caption-blue
268  '((t (:foreground "blue" :background "black")))
269  "Face for caption")
270(defface pdicv-face-caption-green
271  '((t (:foreground "green" :background "black")))
272  "Face for caption")
273(defface pdicv-face-gray
274  '((t (:foreground "gray")))
275  "Face for text")
276
277(defvar pdicv-default-inserter
278  (lambda (eword pron jword example)
279        (progn
280          (set-text-properties 0 (length eword) '(face bold) eword)
281                                        ;       (set-text-properties 0 (length eword) '(face pdicv-face-caption-green) eword)
282                                        ;       (set-text-properties 0 (length jword) '(face pdicv-face-caption-gray) jword)
283
284          (setq jword (nt:replace-all jword "〓●" " // "))
285          (setq jword (nt:replace-all jword "\n" "\n  "))
286
287          (let ((buf ""))
288                (setq buf eword)
289                (when (string< "" pron) (setq buf (concat buf " [" pron "]")))
290                                        ;               (setq result (concat result " : " jword))
291                (setq buf (concat buf "\n  " jword))
292                (when (string< "" example) (setq buf (concat buf "\n  - " example)))
293                                        ;             (setq buf (concat buf "\n"))
294;            (setq buf (concat buf "\n\n"))
295                (setq buf (concat buf "\n"))
296
297                (insert buf)))))
298;;
299;;
300;;
301(defun pdicv-scan-datablock (filename phys criteria-func)
302  "[PDICV] scan a datablock"
303  (catch 'pdicv-scan-datablock
304    (let* ((result ()) ;(match-count 0)
305           (header (pdicv-get-header-info filename))
306                   (tab-sep-p (eq 'unicode-bocu-6 (-> header 'version)))
307                   (block-size (-> header 'block-size))
308           (offset (+ (-> header 'datablock-begins-at) (* phys block-size)))
309                   (aligned (and (member (-> header 'version) '(newdic4 unicode-bocu-6)) t))
310                   ;; (bocu (-> header 'bocu))
311           (head-word (nt:read-ushort (nt:read-from-file filename offset 2)))
312           (blocks (logand 32767 head-word))
313           (block-length (- (* blocks block-size) 2))
314           (field-size (if (zerop (logand 32768 head-word)) 2 4))
315           (datablock (nt:read-from-file filename (+ offset 2) block-length))
316                                        ;    (list blocks field-size datablock)
317           (p 0)
318                   (field-length 0)
319           (compress-length 0)
320           (rest nil)
321           (eword "") (eword-attrib 0)
322           )
323
324      (while (< p block-length) ;    (while (< p field-size)
325        (setq field-length
326              (if (= field-size 2) (nt:read-ushort datablock p) (nt:read-ulong datablock p)) )
327        (when (zerop field-length) (throw 'pdicv-scan-datablock (nreverse result))); sfield-list))
328        (setq p (+ p field-size)) ;2ないし4バイト
329        (setq compress-length (nt:read-uchar datablock p)) ; 圧縮長
330        (setq p (1+ p))
331
332        (when aligned
333                  (setq eword-attrib (nt:read-uchar datablock p)) ; 見出し語属性
334                  (setq p (1+ p)))
335                                        ; 見出し語以降をとりあえず rest に入れる
336        (setq rest (substring datablock p (+ p field-length)))
337        (setq p (+ p field-length))
338                                        ; 見出し語 (NULL終端)
339        (let* ((eword-cstr (nt:read-cstring rest))
340               (eword-compressed (car eword-cstr)) (eword-len (cdr eword-cstr))
341               (q 0)
342               (level 0)
343               (extended nil)
344               (jword-cstr nil) (jword "") (jword-len 0)
345               (ext-list nil)
346               (example "") (pron "") (link ""))
347
348          (setq eword (if (zerop compress-length)
349                          eword-compressed
350                        (concat (substring eword 0 compress-length) eword-compressed) ))
351          (setq q (1+ eword-len))
352                  ;; 見出し語属性
353          (when (not aligned)
354                        (setq eword-attrib (nt:read-uchar rest q))
355                        (setq q (1+ q)))
356
357          (setq level (logand eword-attrib 15))
358;         (insert (format ": %s %d %d\n" eword eword-len eword-attrib))
359;;        (if (zerop (logand eword-attrib 128))
360;;            (throw 'pdicv-scan-datablock ()); 'illegal)
361          (setq eword-attrib (logand eword-attrib 127))
362
363          (setq extended (if (zerop (logand eword-attrib 16)) nil t))
364          (if extended
365              (progn ;拡張
366                (setq jword-cstr (nt:read-cstring rest q))
367                (setq jword (car jword-cstr)) (setq jword-len (cdr jword-cstr))
368                (setq q (+ q jword-len 1))
369                (setq ext-list nil)
370                (catch 'while
371                  (while (< q field-length)
372                    (let* ((ex-attrib (nt:read-uchar rest q))
373                           (ex-attrib-sub (logand ex-attrib 15))
374                           (exdata-cstr nil)
375                           (exdata "") (exdata-len 0) )
376                      (when (= (logand ex-attrib 128) 128) (throw 'while t))
377                      (setq q (1+ q))
378                      (setq exdata-cstr (nt:read-cstring rest q))
379                      (setq exdata (car exdata-cstr))
380                      (setq exdata-len (cdr exdata-cstr))
381                      (cond
382                       ((= ex-attrib-sub 1) (setq example exdata))
383                       ((= ex-attrib-sub 2) (setq pron exdata))
384                       ((= ex-attrib-sub 4) (setq link exdata))
385                       (t nil))
386                      (setq q (+ q exdata-len 1))
387                      ) ; let*
388                    ) ; while
389                  ) ; catch while2
390                ) ; progn
391            (progn ;標準
392              (setq jword (substring rest q))
393              (setq pron "")
394              (setq example ""))
395            ) ; if extended
396
397                  (if tab-sep-p
398                          (let* ((splitted (split-string eword "\t"))
399                                         (eword (car splitted))
400                                         (entry (cadr splitted)))
401                                (when (funcall criteria-func entry eword pron jword example)
402                                  (push (list entry pron jword example) result)))
403                        (when (funcall criteria-func eword eword pron jword example)
404                          (push (list eword pron jword example) result)))
405                  ;;(when (funcall criteria-func eword pron jword example)
406                  ;;    (push (list eword pron jword example) result))
407          );let
408        ); wend
409      (nreverse result))))
410
411(defun pdicv-core-search (dicinfo criteria &optional simple-mode-p dont-clear-p)
412  "search in PDIC"
413  (let* ((dicname (car dicinfo))
414         (dicfile (nth 1 dicinfo))
415         (encoding-list (nth 2 dicinfo))
416         (decoder-list ())
417         (index-table (-> pdicv-index-table-list dicname)))
418;    (if (null index-table) (setq index-table (pdicv-get-index-list dicfile)))
419
420    (when (atom encoding-list) ;; expand encoding-list
421          (setq encoding-list (list encoding-list encoding-list encoding-list encoding-list)))
422 
423    (while encoding-list ;; build the decoder-list
424      (let ((encoding (car encoding-list)))
425        (cond
426         ((eq encoding 'bocu) (push pdicv-bocu-decoder decoder-list))
427         ((eq encoding 'sjis) (push pdicv-sjis-decoder decoder-list))
428         ((eq encoding 'latin1) (push pdicv-latin1-decoder decoder-list))
429         (encoding (push (pdicv-create-decoder encoding) decoder-list))
430         (t (push pdicv-null-decoder decoder-list))))
431      (setq encoding-list (cdr encoding-list)))
432    (setq decoder-list (nreverse decoder-list))
433
434    (catch 'pdicv-core-search
435;      (if (null original-word-to-search) (setq original-word-to-search word-to-search))
436      (let* (;(buffer-name (generate-new-buffer-name *buffer-name))
437                                        ;               (pdicv-buffer-name "*PDIC Viewer*")
438                                        ;               (dummy (if (get-buffer pdicv-buffer-name) (kill-buffer pdicv-buffer-name)))
439             (pdicv-buffer (get-buffer-create "*PDIC Viewer*"))
440                                        ;criteria
441             (word-to-search (car criteria))
442
443             (index-needles (nth 1 criteria))
444             (needle1 (car index-needles))
445             (needle2 (cdr index-needles))
446
447             (datablock-criteria-func (nth 2 criteria))
448
449             (ix index-table) (index-size (length ix)) (curr-size index-size)
450             (ix+ (cadr ix)); next one
451             (match-count 0))
452
453;         (switch-to-buffer pdicv-buffer-name)
454        (save-current-buffer
455          (set-buffer pdicv-buffer)
456          (when (null dont-clear-p) (erase-buffer))
457
458          (when (not simple-mode-p)
459                                        ;(pop-to-buffer pdicv-buffer-name)
460                                        ;              (set-buffer pdicv-buffer-name)
461                        (insert (format "検索文字列: %s\n" word-to-search))
462                        (insert (format "該当件数: ????\n"))
463                        (newline))
464                                        ;(insert "\n"))
465          (when index-needles
466                        (setq ix
467                                  (let ((p ix) (last-p nil))
468                                        (catch 'pdicv-search-in-index
469                                          (while p
470                                                (let* ((elem (car p)) ;(phys (car elem))
471                                                           (word (cdr elem)))
472                                                  (if (string< needle1 word) (throw 'pdicv-search-in-index last-p))
473                                                  ;; (if (string< needle2 word) (throw 'pdicv-search-in-index last-p))
474                            (setq last-p p)
475                            (setq p (cdr p)) ))
476                                          last-p))))
477          (catch 'while
478            (while ix
479              (let* ((curr (car ix))
480                     (phys (car curr)) (word (cdr curr))
481                                         ;; (x (insert (format "* current ix: (%d %s)\n" phys word)))
482                     (result (pdicv-scan-datablock dicfile phys datablock-criteria-func)); decoder-list nil))
483                     (result-count (length result))
484                     (inserter pdicv-default-inserter))
485                (when index-needles
486                                  (when (string>= word needle2) (throw 'while t)))
487                                ;;  (if (not (string< word (cdr index-needles))) (throw 'while t)))
488
489                                        ;               (insert (format "(%s with index %s ... %s)\n"
490                                        ;                               word-to-search
491                                        ;                               (funcall (nth 0 decoder-list) word) result))
492
493                (if result (progn
494                             (while result
495                               (let ((rec (pop result)))
496                                 (funcall inserter
497                                          (funcall (nth 0 decoder-list) (nth 0 rec)); eword
498                                          (funcall (nth 1 decoder-list) (nth 1 rec)); pron
499                                          (funcall (nth 2 decoder-list) (nth 2 rec)); jword
500                                          (funcall (nth 3 decoder-list) (nth 3 rec)); example
501                                          )
502                                 (setq match-count (1+ match-count))
503                                 ))
504                             (message "%5d/%5d:%7d" curr-size index-size match-count)
505                             (sit-for 0))
506                  ;;else
507                                  (when (zerop (% curr-size 128)) ;;128は適当な数
508                                        (message "%5d/%5d:%7d" curr-size index-size match-count))))
509              (setq ix (cdr ix))
510              (setq curr-size (1- curr-size))
511              );wend
512            );caught
513
514                  ;;(insert (pdicv-scan-datablock dicfile (car (car ix)) decoder-list nil needle1 needle2))
515          (goto-char 1)
516
517          (when (not simple-mode-p)
518                        (when (re-search-forward ": [?][?][?][?]" nil t nil)
519                          (replace-match (format ": %d" match-count) t t nil 0)))
520          ); save-current-buffer
521
522;      (pop-to-buffer (current-buffer))
523;        (setq split-height-threshold 6)
524        (when (one-window-p)
525                  (set-window-buffer (split-window-vertically (- pdicv-result-height)) pdicv-buffer))
526        ))))
527
528;;; pdicv-core.el ends here
Note: See TracBrowser for help on using the browser.