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