cgit.sxemacs.org Git - packages/blob - mule-packages/lookup/lisp/lookup-vse.el

   1 ;;; lookup-vse.el --- Lookup Virtual Search Engine
   2 ;; Copyright (C) 1999 Lookup Development Team <lookup@ring.gr.jp>
   3
   4 ;; Author: Keisuke Nishida <kei@psn.net>
   5 ;; Version: $Id: lookup-vse.el,v 1.4 1999/05/23 17:27:21 knishida Exp $
   6
   7 ;; This file is part of Lookup.
   8
   9 ;; Lookup is free software; you can redistribute it and/or modify it
  10 ;; under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2 of the License, or
  12 ;; (at your option) any later version.
  13
  14 ;; Lookup is distributed in the hope that it will be useful, but
  15 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with Lookup; if not, write to the Free Software Foundation,
  21 ;; Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  22
  23 ;;; Code:
  24
  25 (require 'lookup)
  26
  27 ;;;;;;;;;;;;;;;;;;;;
  28 ;: Search Query
  29 ;;;;;;;;;;;;;;;;;;;;
  30
  31 ;;;###autoload
  32 (defun lookup-vse-search-query (dictionary query)
  33   ;; DICTIONARY \e$B$+$i\e(B QUERY \e$B$r8!:w$9$k!#\e(B
  34   ;; \e$BJQ?t\e(B `lookup-force-update' \e$B$,\e(B non-nil \e$B$N>l9g!"%-%c%C%7%e$rL5;k$9$k!#\e(B
  35   ;; \e$B<B:]$K8!:w$r9T$J$&$N$O\e(B `lookup-vse-search-query-internal'.
  36   (let ((entries (lookup-entries-cache-get dictionary query)))
  37     (when (or (not entries) lookup-force-update)
  38       (setq entries (lookup-vse-search-query-internal dictionary query))
  39       (lookup-entries-cache-put dictionary query (or entries 'no-exists)))
  40     (unless (eq entries 'no-exists)
  41       entries)))
  42
  43 (defvar lookup-entries-cache nil)
  44
  45 (defun lookup-entries-cache-get (dictionary query)
  46   (lookup-multi-get 'lookup-entries-cache dictionary
  47                     (lookup-query-method query)
  48                     (lookup-intern-string (lookup-query-string query))))
  49
  50 (defun lookup-entries-cache-put (dictionary query entries)
  51   (lookup-multi-put 'lookup-entries-cache dictionary
  52                     (lookup-query-method query)
  53                     (lookup-intern-string (lookup-query-string query))
  54                     entries))
  55
  56 (defun lookup-entries-cache-clear ()
  57   (setq lookup-entries-cache nil))
  58
  59 ;;;###autoload
  60 (defun lookup-vse-search-query-internal (dictionary query)
  61   (let (entries)
  62     (if (not (eq (lookup-query-method query) 'stemming))
  63         (setq entries (lookup-dictionary-command dictionary 'search query))
  64       ;; stemming
  65       (let* ((method (lookup-dictionary-default-method dictionary))
  66              (stemmer (lookup-dictionary-stemmer dictionary))
  67              (string (lookup-query-string query))
  68              (candidates (nreverse (funcall stemmer string))))
  69         (while candidates
  70           (setq query (lookup-make-query method (car candidates)))
  71           (setq entries (lookup-vse-search-query dictionary query))
  72           (setq candidates (if entries nil (cdr candidates))))
  73         (if entries
  74             (let ((prefix (concat "[" string " ->] ")))
  75               (setq entries (mapcar (lambda (entry)
  76                                       (setq entry (lookup-copy-entry entry))
  77                                       (lookup-entry-set-prefix entry prefix)
  78                                       entry)
  79                                     entries))))))
  80     (lookup-foreach 'lookup-arrange-heading entries)
  81     entries))
  82
  83 \f
  84 ;;;;;;;;;;;;;;;;;;;;
  85 ;: Insert content
  86 ;;;;;;;;;;;;;;;;;;;;
  87
  88 (defun lookup-vse-insert-content (entry)
  89   ;; ENTRY \e$B$NFbMF$r%P%C%U%!$KA^F~$7!"@07A=hM}$r9T$J$&!#\e(B
  90   ;; \e$BJQ?t\e(B `lookup-force-update' \e$B$,\e(B non-nil \e$B$N>l9g!"%-%c%C%7%e$rL5;k$9$k!#\e(B
  91   (let ((cache (lookup-contents-cache-get entry lookup-enable-format)))
  92     (if (or (not cache) lookup-force-update)
  93         ;; insert content
  94         (let ((lookup-proceeding-message
  95                (format "Inserting `%s'" (lookup-entry-heading entry)))
  96               (dictionary (lookup-entry-dictionary entry)))
  97           (lookup-proceeding-message nil)
  98           (insert (lookup-dictionary-command dictionary 'content entry))
  99           (if lookup-enable-format (lookup-arrange-content entry))
 100           (lookup-contents-cache-put entry lookup-enable-format
 101                                      (buffer-string))
 102           (if lookup-enable-format (lookup-adjust-content entry))
 103           (lookup-proceeding-message t))
 104       ;; use cache
 105       (insert cache)
 106       (if lookup-enable-format (lookup-adjust-content entry)))))
 107
 108 (defvar lookup-contents-cache nil)
 109
 110 (defun lookup-contents-cache-put (entry formatted content)
 111   (lookup-multi-put
 112    'lookup-contents-cache (lookup-entry-dictionary entry) formatted
 113    (lookup-assoc-set (lookup-multi-get 'lookup-contents-cache
 114                                        (lookup-entry-dictionary entry)
 115                                        formatted)
 116                      (lookup-entry-code entry) content)))
 117
 118 (defun lookup-contents-cache-get (entry formatted)
 119   (lookup-assoc-ref (lookup-multi-get 'lookup-contents-cache
 120                                       (lookup-entry-dictionary entry)
 121                                       formatted)
 122                     (lookup-entry-code entry)))
 123
 124 (defun lookup-contents-cache-clear ()
 125   (setq lookup-contents-cache nil))
 126
 127 ;;;
 128 ;:: Interface functions
 129 ;;;
 130
 131 (defun lookup-arrange-heading (entry)
 132   (let* ((dictionary (lookup-entry-dictionary entry))
 133          (funcs (lookup-dictionary-headings dictionary)))
 134     (when funcs
 135       (with-temp-buffer
 136         (insert (lookup-entry-heading entry))
 137         (lookup-foreach (lambda (func)
 138                           (goto-char (point-min))
 139                           (funcall func entry))
 140                         funcs)
 141         (lookup-entry-set-heading entry (buffer-string))))))
 142
 143 (defun lookup-arrange-content (entry)
 144   (let* ((dictionary (lookup-entry-dictionary entry))
 145          (arranges (lookup-dictionary-option dictionary ':arranges t)))
 146     (lookup-format entry arranges "formatting")))
 147
 148 (defun lookup-adjust-content (entry)
 149   (let* ((dictionary (lookup-entry-dictionary entry))
 150          (adjusts (lookup-dictionary-option dictionary ':adjusts t))
 151          (arranges (lookup-dictionary-option dictionary ':arranges t))
 152          (work (concat "formatting" (make-string (length arranges) ?.))))
 153     (lookup-format entry adjusts work)))
 154
 155 ;;;
 156 ;:: Internal functions
 157 ;;;
 158
 159 (defun lookup-format (entry functions work)
 160   (let ((n 1))
 161     (lookup-foreach (lambda (func)
 162                       (lookup-proceeding-message
 163                        (concat work (make-string (setq n (1+ n)) ?.)))
 164                       (widen)
 165                       (goto-char (point-min))
 166                       (funcall func entry))
 167                     functions)))
 168
 169 (defun lookup-heading-face (level)
 170   (or (nth (1- level) '(lookup-heading-1-face
 171                         lookup-heading-2-face lookup-heading-3-face
 172                         lookup-heading-4-face lookup-heading-5-face))
 173       'lookup-heading-low-face))
 174
 175 ;;;
 176 ;:: Arrange functions
 177 ;;;
 178
 179 (defsubst lookup-make-region-heading (start end level)
 180   (add-text-properties start end (list 'face (lookup-heading-face level)
 181                                        'lookup-heading level)))
 182
 183 (defun lookup-arrange-default-headings (entry)
 184   (lookup-make-region-heading (point) (progn (end-of-line) (point)) 1))
 185
 186 (defun lookup-arrange-references (entry)
 187   (let* ((case-fold-search nil)
 188          (dictionary (lookup-entry-dictionary entry))
 189          (pattern (lookup-dictionary-option dictionary ':reference-pattern t))
 190          (regexp (car pattern)) (region-field (nth 1 pattern))
 191          (heading-field (nth 2 pattern)) (code-field (nth 3 pattern))
 192          region heading code reference)
 193     (while (re-search-forward regexp nil t)
 194       (save-match-data
 195         (setq region (if (integerp region-field)
 196                          (match-string region-field)
 197                        (eval region-field)))
 198         (setq heading (if (integerp heading-field)
 199                           (match-string heading-field)
 200                         (eval heading-field)))
 201         (if (integerp code-field)
 202             (setq code (match-string code-field)
 203                   reference (lookup-make-entry dictionary code heading))
 204           (setq reference (lookup-make-reference dictionary heading heading))
 205           (lookup-reference-make-dynamic reference code-field)))
 206       (replace-match region t t)
 207       (lookup-set-link (match-beginning 0) (point) reference)
 208       (lookup-arrange-heading reference))))
 209
 210 (defun lookup-dynamic-code-search (reference)
 211   "\e$B%j%U%!%l%s%9$N%3!<%I$r%@%$%J%_%C%/$K8!:w$9$k!#\e(B"
 212   (let ((dictionary (lookup-entry-dictionary reference))
 213         (query (lookup-make-query 'exact (lookup-entry-code reference))))
 214     (lookup-vse-search-query dictionary query)))
 215
 216 (defun lookup-arrange-gaijis (entry)
 217   (let* ((case-fold-search t)
 218          (dictionary (lookup-entry-dictionary entry))
 219          (regexp (lookup-dictionary-option dictionary ':gaiji-regexp t))
 220          start end gaiji)
 221     (while (re-search-forward regexp nil t)
 222       (setq start (match-beginning 0) end (match-end 0))
 223       (when (setq gaiji (lookup-vse-get-gaiji dictionary (match-string 1)))
 224         (delete-region start end)
 225         (lookup-gaiji-insert gaiji)))))
 226
 227 (defun lookup-arrange-fill-lines (entry)
 228   (let ((fill-column (if (integerp lookup-fill-column)
 229                          lookup-fill-column
 230                        (round (* (window-width) lookup-fill-column))))
 231         start)
 232     (while (not (eobp))
 233       (setq start (point))
 234       (end-of-line)
 235       (if (> (current-column) fill-column)
 236           (fill-region start (point)))
 237       (forward-line))))
 238
 239 (defun lookup-arrange-fill-paragraphs (entry)
 240   (text-mode)
 241   (let ((fill-column (if (integerp lookup-fill-column)
 242                          lookup-fill-column
 243                        (round (* (window-width) lookup-fill-column)))))
 244     (while (not (eobp))
 245       (fill-paragraph nil)
 246       (forward-paragraph))))
 247
 248 (defun lookup-arrange-squeezed-references (entry)
 249   (if (lookup-dictionary-option
 250        (lookup-entry-dictionary entry) ':squeezed nil)
 251       (while (search-forward-regexp "\e$B"*""\e(B\\(#0001\\|<gaiji:z0001>\\)?" nil t)
 252         (replace-match ""))))
 253
 254 ;;;
 255 ;:: Adjust functions
 256 ;;;
 257
 258 (defun lookup-adjust-show-gaijis (entry)
 259   (lookup-map-over-property
 260    (point-min) (point-max) 'lookup-gaiji 'lookup-gaiji-glyph-paste))
 261
 262 (defun lookup-adjust-check-references (entry)
 263   (lookup-map-over-property
 264    (point-min) (point-max) 'lookup-reference
 265    (lambda (start end reference)
 266      (if (if (lookup-reference-p reference)
 267              (lookup-reference-refered-p reference)
 268            (lookup-entry-refered-p reference))
 269          (put-text-property start end 'face 'lookup-refered-face)
 270        (put-text-property start end 'face 'lookup-reference-face)))))
 271
 272 (defun lookup-adjust-goto-min (entry)
 273   (goto-char (point-min)))
 274
 275 \f
 276 ;;;;;;;;;;;;;;;;;;;;
 277 ;: Other Functions
 278 ;;;;;;;;;;;;;;;;;;;;
 279
 280 ;;;###autoload
 281 (defun lookup-vse-get-menu (dictionary)
 282   (let ((entries (lookup-dictionary-get-property dictionary 'menu-entries)))
 283     (unless entries
 284       (when (lookup-dictionary-command-p dictionary 'menu)
 285         (setq entries (lookup-dictionary-command dictionary 'menu))
 286         (lookup-foreach 'lookup-arrange-heading entries)
 287         (lookup-dictionary-put-property dictionary 'menu-entries entries)))
 288     entries))
 289
 290 (defun lookup-vse-open-entry (entry)
 291   (let ((dictionary (lookup-entry-dictionary entry)))
 292     (when (lookup-dictionary-command-p dictionary 'open)
 293       (lookup-dictionary-command dictionary 'open entry)
 294       t)))
 295
 296 (defun lookup-vse-get-gaiji (dictionary code)
 297   (let* ((table (lookup-dictionary-gaiji-table dictionary))
 298          (gaiji (lookup-gaiji-table-ref table code))
 299          (glyph (if gaiji (lookup-gaiji-glyph gaiji)))
 300          (alter (if gaiji (lookup-gaiji-alternate gaiji))))
 301     (unless (and gaiji glyph alter)
 302       (if (or (not lookup-enable-gaiji) (not (lookup-gaiji-glyph-possible-p)))
 303           (if alter (lookup-gaiji-set-glyph gaiji alter))
 304         (setq alter (format lookup-gaiji-alternate code))
 305         (if glyph
 306             (lookup-gaiji-set-alternate gaiji alter)
 307           (when (setq glyph (lookup-dictionary-command dictionary 'gaiji code))
 308             (setq glyph (lookup-gaiji-glyph-compose glyph))
 309             (if gaiji
 310                 (lookup-gaiji-set-glyph gaiji glyph)
 311               (setq gaiji (lookup-make-gaiji glyph alter))
 312               (lookup-gaiji-table-set table code gaiji))))))
 313     gaiji))
 314
 315 (provide 'lookup-vse)
 316
 317 ;;; lookup-vse.el ends here