;;; sirup.el --- Simple Implementation of dictionaRy lookUP client

;; Author: YAMAMOTO Mitsuharu <mituharu@math.s.chiba-u.ac.jp>
;; Created: 14 Dec 1997
;; Version: 1.1beta
;;
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, you can either send email to this
;; program's author (see above or write to:
;;
;;              The Free Software Foundation, Inc.
;;              675 Mass Ave.
;;              Cambridge, MA 02139, USA.
;;

;;; Commentary:
;;
;; インストールの仕方は、パッケージに附属の README.sirup を御覧下さい。
;;
;; ユーザレベルの設定:
;; 設定ファイル(~/.emacs など)に以下のものを加えて下さい。
;;
;;   (autoload 'sirup "sirup" "Simple Dictionary Lookup." t nil)
;;   (autoload 'sirup-other-window "sirup"
;;             "Like `sirup', but the buffer is displayed in another window."
;;             t nil)
;;
;; M-x sirup RET (または M-x sirup-other-window RET) で起動します。
;;
;; 起動時に自動的に "eiwa" 辞書が選択されるようにするには以下のように
;; して下さい。
;;
;;   (setq sirup-default-dictionary "eiwa")

;;; Code:

(require 'ndtp)

(defconst sirup-version "1.1beta")

;;;; Site-local variables.
(defvar dserver-server-list '("dserver" "localhost")
  "*Site default value of the list of dservers.
Each element must be of the form either

	\"hostname\"
or
	'(\"hostname\" . \"service\").

If an element is of the first form, the value of
`dserver-service' is used for dserver service name or its port number.")
(defvar dserver-service ndtp-default-service
  "*Name of dserver service or its port number.")
(defvar sirup-dictionary-list '("eiwa" "waei" "kojien")
  "*List of avaliable dictionary names
`Sirup' tries to construct a list of available dictionaries with
queries to servers.  But if this facility seems to fail, add
dictionary names to this list.")

;;;; User variables.
(defvar sirup-server-list (or (ndtp-parse-dserver-env t) dserver-server-list)
  "*User configurable value of the list of dservers.
See the documentation of `dserver-server-list'.
The defalut value may be created from the value of the environment
variable `DSERVER', which is of the following form:
	host1[:service1][,host2[:service2],...,hostn[:servicen]]")
(defvar sirup-default-dictionary nil
  "*Dictionary automatically selected at the startup of sirup.")
(defvar sirup-show-unique-entry-immediately t
  "*Non-nil means the unique entry is displayed automatically.")
(defvar sirup-mode-hook nil)
(defvar sirup-quit-hook nil)
(defvar sirup-suspend-hook nil)
(defvar sirup-show-body-hook nil)
(defvar sirup-show-entries-hook nil)
(defvar sirup-insert-title-hook nil)
(defvar sirup-asynchronous-flag nil
  "*Non-nil means communication between ndtp server is done asynchronously.
Currently this feature works but only for tests of `ndtp.el'.")

;;;; buffer-local user variables.
(defvar sirup-narrow-to-page-flag t
  "*Non-nil means a buffer is narrowed to its current page.")

;;;; internal variables and constants.
(defvar sirup-process-list nil)
(defvar sirup-mode-map nil)
(defvar sirup-dictionary-table nil)
(defconst sirup-link-regexp "<[0-9a-f]+:[0-9a-f]+>")
(defconst sirup-index-caption-table
  '((HA "メニュー検索" . t)
    (OK "著作権表示" . t)
;;;    (ZI "条件検索")
    (BK "かな後方検索")
    (IK "かな前方検索")
    (BA "表記後方検索(電子ブックではアルファベット後方検索)")
    (IA "表記前方検索(電子ブックではアルファベット前方検索)")
;;;    (HO "本文")
    ))
(defconst sirup-index-type-table
  '((BK ?K . ?A)
    (IK ?k . ?a)
    (BA ?A)
    (IA ?a)))

;;;; buffer-local internal variables
(defvar sirup-process)
(defvar sirup-dictionary)
(defvar sirup-server-implementation)
(defvar sirup-index-available)

(defconst sirup-buffer-local-variables
  '(sirup-narrow-to-page-flag
    sirup-process
    sirup-dictionary
    sirup-server-implementation
    sirup-index-available))

(autoload 'sirup-show-system-document "sirup-doc")

(defmacro sirup-server-name (server)
  (` (if (consp (, server)) (car (, server)) (, server))))
(defmacro sirup-server-service (server)
  (` (if (consp (, server)) (cdr (, server)) dserver-service)))

(defun sirup-add-meta (sym)
  (vector (intern (concat "M-" (symbol-name sym)))))
(if (string-match "XEmacs\\|Lucid" emacs-version)
    (fset 'sirup-add-meta
	  (function (lambda (sym) (list 'meta sym)))))

(if (null sirup-mode-map)
    (progn
      (setq sirup-mode-map (make-keymap))
      (suppress-keymap sirup-mode-map)
      (define-key sirup-mode-map "?"	'describe-mode)
      (define-key sirup-mode-map " "	'scroll-up)
      (define-key sirup-mode-map "\177"	'scroll-down)
      (define-key sirup-mode-map "\C-i"	'sirup-next-link)
      (define-key sirup-mode-map "\C-o"	'sirup-previous-link)
      (define-key sirup-mode-map "\e\C-i" 'sirup-previous-link)
      (define-key sirup-mode-map "\C-m"	'sirup-follow-link)
      (define-key sirup-mode-map "="	'sirup-toggle-narrow-to-page)
      (define-key sirup-mode-map "["	'sirup-backward-page)
      (define-key sirup-mode-map "]"	'sirup-forward-page)
      (define-key sirup-mode-map "^"	'sirup-goto-parent)
      (define-key sirup-mode-map "_"	'sirup-forward-page)
      (define-key sirup-mode-map "<"	'sirup-show-previous-sibling)
      (define-key sirup-mode-map ">"	'sirup-show-next-sibling)
      (define-key sirup-mode-map "\eu"	'sirup-goto-parent)
      (define-key sirup-mode-map "\ed"	'sirup-forward-page)
      (define-key sirup-mode-map "\ep"	'sirup-show-previous-sibling)
      (define-key sirup-mode-map "\en"	'sirup-show-next-sibling)
      ;;(define-key sirup-mode-map "+"	'enlarge-window)
      ;;(define-key sirup-mode-map "-"	'shrink-window)
      (define-key sirup-mode-map "\C-d"	'sirup-select-dictionary)
      (define-key sirup-mode-map "\C-t"	'sirup-show-title)
      (define-key sirup-mode-map "\C-k"	'sirup-kill-buffer)
      (define-key sirup-mode-map "\C-w"	'sirup-duplicate-buffer)
      (define-key sirup-mode-map "\C-q"	'sirup-suspend)
      (define-key sirup-mode-map "\eq"	'sirup-quit)
      (define-key sirup-mode-map "\C-j"	'sirup-read-pattern)
      (define-key sirup-mode-map "\C-y"	'sirup-read-pattern-unread)
      (define-key sirup-mode-map "\C-\\" 'sirup-read-pattern-unread)
      (let ((string "a"))
	(while (progn
		 (define-key sirup-mode-map string 'sirup-start-read-pattern)
		 (< (aref string 0) ?z))
	  (aset string 0 (1+ (aref string 0)))))
      (define-key sirup-mode-map "*" 'sirup-start-read-pattern)
      ;; remaining 1-stroke(?) keys:
      ;; (no modifiers)	!"#$%&'()+,./:;@\`{|}~ and A-Z
      ;; C-...		_
      ;; M-...		SPC %'/;\^cgiojkl  st yz DEL
      ;; M-C-...	           g ojk mq txyz\]^_
      (if (>= ndtp-emacs-major-version 19)
	  (progn
	    (define-key sirup-mode-map
	      (sirup-add-meta 'up)	'sirup-goto-parent)
	    (define-key sirup-mode-map
	      (sirup-add-meta 'down)	'sirup-forward-page)
	    (define-key sirup-mode-map
	      (sirup-add-meta 'left)	'sirup-show-previous-sibling)
	    (define-key sirup-mode-map
	      (sirup-add-meta 'right)	'sirup-show-next-sibling)))))

(defun sirup-mode ()
  "Major mode for looking up words using ndtp servers.
To see usage, type `\\[sirup-show-title]' and follow instructions.

Commands:
\\{sirup-mode-map}"
  (interactive)
  (kill-all-local-variables)
  (setq major-mode 'sirup-mode)
  (setq mode-name "Simple Dictionary Lookup")
  (use-local-map sirup-mode-map)
  (setq buffer-read-only t)
  (buffer-flush-undo (current-buffer))
  (mapcar 'make-local-variable sirup-buffer-local-variables)
  (run-hooks 'sirup-mode-hook))

;;;###autoload
(defun sirup (&optional arg)
  (interactive "P")
  (sirup-start arg 'switch-to-buffer))

;;;###autoload
(defun sirup-other-window (&optional arg)
  (interactive "P")
  (sirup-start arg 'switch-to-buffer-other-window))

(defun sirup-start (arg switch-to-buffer-function)
  (funcall switch-to-buffer-function
	   (if arg
	       (sirup-set-dictionary-buffer (sirup-read-dictionary))
	     (or (sirup-find-buffer)
		 (sirup-set-dictionary-buffer
		  (or sirup-default-dictionary
		      (sirup-read-dictionary)))))))

(defun sirup-quit ()
  (interactive)
  (run-hooks 'sirup-quit-hook)
  (let ((buffer-list (buffer-list)))
    (while buffer-list
      (save-excursion
	(set-buffer (car buffer-list))
	(if (eq major-mode 'sirup-mode)
	    (progn
	      ;; Don't exchange the following two lines because
	      ;; `delete-windows-on' will change the current buffer.
	      (kill-buffer (current-buffer))
	      (delete-windows-on (current-buffer)))))
      (setq buffer-list (cdr buffer-list))))
  (let ((process-list sirup-process-list))
    (while process-list
      (if (and (car process-list)
	       (eq (process-status (car process-list)) 'open))
	  (ndtp-close (car process-list)))
      (setq process-list (cdr process-list))))
  (setq sirup-process-list nil)
  (setq sirup-dictionary-table nil))

(defun sirup-suspend ()
  (interactive)
  (run-hooks 'sirup-suspend-hook)
  ;; Don't exchange the following two lines because
  ;; `delete-windows-on' will change the current buffer.
  (bury-buffer (current-buffer))
  (delete-windows-on (current-buffer)))

(defun sirup-kill-buffer ()
  (interactive)
  (kill-buffer (current-buffer))
  (if (and (null (sirup-find-buffer))
	   (y-or-n-p "Killed all `Sirup' buffers.  Close connections?"))
      (progn (sirup-quit)
	     (message ""))))

(defun sirup-copy-buffer-local-variables (variables source
                                                    &optional destination)
  (setq destination (or destination (current-buffer)))
  (save-excursion
    (if source (set-buffer source))
    (mapcar (function (lambda (value)
			(set (car (prog1 variables
				    (setq variables (cdr variables))))
			     value)))
	    (prog1 (mapcar 'symbol-value variables)
	      (set-buffer destination)))))

(defun sirup-duplicate-buffer (&optional arg)
  (interactive "P")
  (let* ((source-buffer (current-buffer))
	 (source-point (point))
	 (source-point-min (point-min))
	 (source-point-max (point-max))
	 (buffer-name
	  (generate-new-buffer-name (format "*Sirup %s*" sirup-dictionary))))
    (if arg
	(progn
	  (setq arg (read-string
		     (format "Buffer name (default %s): " buffer-name)))
	  (if (not (string= arg ""))
	      (setq buffer-name arg))))
    (save-excursion
      (save-restriction
	(widen)
	(set-buffer (generate-new-buffer buffer-name))
	(sirup-mode)
	(sirup-copy-buffer-local-variables sirup-buffer-local-variables
					   source-buffer)
	(let (buffer-read-only)
	  (insert-buffer-substring source-buffer))
	(set-buffer-modified-p nil)
	(goto-char source-point)
	(narrow-to-region source-point-min source-point-max)
	(message "Buffer contents are copied to `%s'" (buffer-name))))))

(defun sirup-find-buffer (&optional dictionary)
  (let ((buffer-list (buffer-list)))
    (while (and buffer-list
		(save-excursion
		  (set-buffer (car buffer-list))
		  (not (and (eq major-mode 'sirup-mode)
			    (or (null dictionary)
				(string= sirup-dictionary dictionary))))))
      (setq buffer-list (cdr buffer-list)))
    (car buffer-list)))

(defun sirup-select-dictionary ()
  (interactive)
  (sirup-show-buffer (sirup-set-dictionary-buffer (sirup-read-dictionary)) t))

(defun sirup-read-dictionary ()
  (if (null sirup-dictionary-table)
      (if (null (sirup-connect-to-servers))
	  (error "Can't find any connectable servers.")))
  (let ((key (let ((completion-ignore-case t))
	       (completing-read
		(if sirup-default-dictionary
		    (format  "Dictionary name(default: %s): "
			     sirup-default-dictionary)
		  "Dictionary name: ")
		sirup-dictionary-table nil t))))
    (if (string= key "")
	(or sirup-default-dictionary key)
      (cdr (sirup-assoc key sirup-dictionary-table)))))

(defun sirup-set-dictionary-buffer (&optional dictionary)
  (let ((buffer (sirup-find-buffer dictionary)))
    (or buffer
	(let ((process (sirup-find-process dictionary)))
	  (if (null process)
	      (error "Can't set dictionary `%s'." dictionary)
	    (prog1 (set-buffer (generate-new-buffer
				(format "*Sirup %s*" dictionary)))
	      (sirup-mode)
	      (setq sirup-process process)
	      (setq sirup-dictionary dictionary)
	      (setq sirup-server-implementation
		    (ndtp-guess-server-implementation process))
	      (setq sirup-index-available (sirup-get-index-available process))
	      (sirup-insert-title)
	      (sirup-beginning-of-page)))))))

(defun sirup-find-process (dictionary)
  (if (null (sirup-connect-to-servers))
      nil
    (let ((process-list sirup-process-list))
      (while (and process-list
		  (not (and (car process-list)
			    (string= (ndtp-command-result
				      (ndtp-get-dictionary
				       (car process-list) dictionary))
				     "$*"))))
	(setq process-list (cdr process-list)))
      (car process-list))))

(defun sirup-show-buffer (&optional buffer window-start point)
  (select-window
   (prog1 (selected-window)
     (if (save-excursion
	   (set-buffer (window-buffer (selected-window)))
	   (eq major-mode 'sirup-mode))
	 (switch-to-buffer (or buffer (current-buffer)))
       (switch-to-buffer-other-window (or buffer (current-buffer))))
     (if window-start
	 (progn
	   (if (integer-or-marker-p window-start)
	       (goto-char window-start)
	     (sirup-beginning-of-page))
	   (recenter 0)))
     (if sirup-narrow-to-page-flag
	 (narrow-to-page))
     (if point
	 (goto-char point)))))

;;;(defun sirup-switch-to-buffer (buffer)
;;;  (if (save-excursion
;;;	(set-buffer (window-buffer (selected-window)))
;;;	(eq major-mode 'sirup-mode))
;;;      (switch-to-buffer buffer)
;;;    (switch-to-buffer-other-window buffer)))

(defun sirup-get-index-available (process)
  (mapcar (function (lambda (index)
		      (cons (intern (substring index 0 2))
			    (substring index 3))))
	  (ndtp-command-result (ndtp-get-index process))))

(defun sirup-open-dictionary ()
  (if (not (and sirup-process
		(eq (process-status sirup-process) 'open)
		(string= (ndtp-command-result
			  (ndtp-get-dictionary sirup-process sirup-dictionary))
			 "$*")))
      (if (null (setq sirup-process (sirup-find-process sirup-dictionary)))
	  (error "Can't open dictionary `%s'." sirup-dictionary)
	(setq sirup-server-implementation
	      (ndtp-guess-server-implementation sirup-process))
	(setq sirup-index-available
	      (sirup-get-index-available sirup-process)))))

(defun sirup-connect-to-servers ()
  (let ((server-list sirup-server-list)
	new-process-list process)
    (while server-list
      (let ((server (car server-list)))
	(setq process (car sirup-process-list))
	(if (not (and sirup-process-list
		      (or (null process) (eq (process-status process) 'open))))
	    (progn
	      (message "Connecting to %s server on %s..."
		       (sirup-server-service server)
		       (sirup-server-name server))
	      (if (condition-case nil
		      (setq process (ndtp-open (sirup-server-name server)
					       (sirup-server-service server)))
		    (file-error (setq process nil)))
		  (if (not (eq (ndtp-command-status
				(ndtp-get-access-permission process)) t))
		      (progn
			(ndtp-close process t)
			(setq process nil))))
	      (message "")))
	(setq sirup-process-list (cdr sirup-process-list))
	(setq new-process-list (cons process new-process-list)))
      (setq server-list (cdr server-list)))
    (if (eval (cons 'or new-process-list))
	(progn
	  (setq sirup-process-list (nreverse new-process-list))
	  (if (null sirup-dictionary-table)
	      (setq sirup-dictionary-table
		    (sirup-make-dictionary-table sirup-process-list))))
      (setq sirup-process-list nil)))
  sirup-process-list)

(defun sirup-extract-dictionary (str)
  (string-match "\t[^\t]+\t\\([^\t ]+\\)[\t ]" str)
  (substring str (match-beginning 1) (match-end 1)))

(defun sirup-assoc (key list)
  (while (and list (not (equal key (car (car list)))))
    (setq list (cdr list)))
  (car list))
(if (fboundp 'assoc)
    (fset 'sirup-assoc (symbol-function 'assoc)))

(defun sirup-assoc-ignore-case (key list)
  (setq key (downcase key))
  (while (and list (not (equal key (downcase (car (car list))))))
    (setq list (cdr list)))
  (car list))

(defun sirup-add-to-dictionary-table (key dictionary dictionary-table)
  (if (sirup-assoc-ignore-case key dictionary-table)
      dictionary-table
    (cons (cons key dictionary) dictionary-table)))

(defun sirup-register-dictionary (dictionary-titles dictionary-table)
  (while dictionary-titles
    (let ((dictionary (sirup-extract-dictionary (car dictionary-titles))))
      (setq dictionary-table
	    (sirup-add-to-dictionary-table
	     dictionary dictionary dictionary-table))
      (if (string-match "/" dictionary)
	  (setq dictionary-table
		(sirup-add-to-dictionary-table
		 (substring dictionary (match-end 0))
		 dictionary dictionary-table))))
    (setq dictionary-titles (cdr dictionary-titles)))
  dictionary-table)

(defun sirup-make-dictionary-table (process-list)
  (let ((dictionary-table (mapcar (function (lambda (x) (cons x x)))
				  sirup-dictionary-list)))
    (while process-list
      (if (car process-list)
	  (setq dictionary-table
		(sirup-register-dictionary
		 (ndtp-command-result
		  (ndtp-get-titles (car process-list)))
		 dictionary-table)))
      (setq process-list (cdr process-list)))
    dictionary-table))

(defun sirup-beginning-of-page ()
  (save-restriction
    (narrow-to-page)
    (goto-char (point-min))))

(defun sirup-end-of-page ()
  (save-restriction
    (narrow-to-page)
    (goto-char (point-max))))

(defun sirup-next-link (&optional count this-page-only)
  (interactive "p")
  (save-restriction
    (if this-page-only
	(narrow-to-page))
    (let (case-fold-search)
      (if (looking-at sirup-link-regexp)
	  (setq count (1+ (or count 1))))
      (if (re-search-forward sirup-link-regexp nil t count)
	  (goto-char (1+ (match-beginning 0)))))))

(defun sirup-previous-link (&optional count this-page-only)
  (interactive "p")
  (save-restriction
    (if this-page-only
	(narrow-to-page))
    (let (case-fold-search)
      (if (re-search-backward sirup-link-regexp nil t count)
	  (goto-char (1+ (match-beginning 0)))))))

(defun sirup-match-link ()
  (let (case-fold-search)
    (cond ((eq (following-char) ?<)
	   (looking-at sirup-link-regexp))
	  ((save-excursion
	     (and (search-backward
		   "<" (save-excursion (beginning-of-line) (point)) t)
		  (looking-at sirup-link-regexp)))
	   (and (<= (point) (match-end 0))
		(or (< (point) (match-end 0))
		    (eq (char-syntax (following-char)) ?\ )))))))

(defun sirup-toggle-narrow-to-page ()
  (interactive)
  (if (setq sirup-narrow-to-page-flag (not sirup-narrow-to-page-flag))
      (narrow-to-page)
    (widen)))

(defun sirup-follow-link ()
  (interactive)
  (if (sirup-match-link)
      (progn
	(goto-char (1+ (match-beginning 0)))
	(sirup-show-body
	 (buffer-substring (point) (1- (match-end 0)))))
    (sirup-read-pattern (sirup-word-at-point))))

(defun sirup-forward-page (&optional count)
  (interactive "p")
  (widen)
  (forward-page count)
  (if sirup-narrow-to-page-flag
      (narrow-to-page)))

(defun sirup-backward-page (&optional count)
  (interactive "p")
  (widen)
  (backward-page count)
  (if sirup-narrow-to-page-flag
      (narrow-to-page)))

(defun sirup-goto-parent-if-exists ()
  (let ((parent-point
	 (save-excursion
	   (sirup-beginning-of-page)
	   (if (/= (point) 1)		; (not (bobp)) can't be used here
	       (progn
		 (widen)
		 (read (current-buffer)))))))
    (if parent-point
	(goto-char parent-point))))

(defun sirup-goto-parent ()
  (interactive)
  (if (null (sirup-goto-parent-if-exists))
      (message "No parent.")
    (if sirup-narrow-to-page-flag
	(narrow-to-page))))

(defun sirup-show-previous-sibling (&optional count)
  (interactive)
  (let ((point-save (point)))
    (if (null (sirup-goto-parent-if-exists))
	(message "No parent.")
      (if (sirup-previous-link count t)
	  (sirup-follow-link)
	(message "No previous sibling.")
	(goto-char point-save)
	(if sirup-narrow-to-page-flag
	    (narrow-to-page))))))

(defun sirup-show-next-sibling (&optional count)
  (interactive)
  (let ((point-save (point)))
    (if (null (sirup-goto-parent-if-exists))
	(message "No parent.")
      (if (sirup-next-link count t)
	  (sirup-follow-link)
	(message "No next sibling.")
	(goto-char point-save)
	(if sirup-narrow-to-page-flag
	    (narrow-to-page))))))

(defun sirup-heading-around (&optional link-start prefix-width total-width)
  (or prefix-width (setq prefix-width 50))
  (or total-width (setq total-width 60))
  (save-excursion
    (goto-char (or link-start (setq link-start (point))))
    (let* ((link-start-column (current-column))
	   (limit (save-excursion
		    (move-to-column
		     (max 0 (- link-start-column prefix-width)))
		    (point)))
	   (ellipsis "") heading heading-width
	   case-fold-search)
      (if (re-search-backward sirup-link-regexp limit 'move-to-limit)
	  (goto-char (match-end 0)))
      (if (/= (current-column) 0)
	  (setq ellipsis "..."))
      (skip-chars-forward " \t")
      (setq heading (concat ellipsis (buffer-substring (point) link-start)))
      (setq heading-width (+ (- link-start-column (current-column))
			     (length ellipsis)))
      (goto-char link-start)
      (re-search-forward sirup-link-regexp nil)
      (setq link-start (point))
      ;; now link-start is actually link-end
      (setq limit (save-excursion
		    (move-to-column
		     (- (+ total-width (current-column)) heading-width))
		    (point)))
      (if (re-search-forward sirup-link-regexp limit 'move-to-limit)
	  (goto-char (match-beginning 0)))
      (skip-chars-backward " \t")
      (concat heading "<..>" (buffer-substring link-start (point))))))

(defun sirup-start-read-pattern ()
  (interactive)
  (sirup-read-pattern (this-command-keys)))
(if (fboundp 'events-to-keys)
    (fset 'sirup-start-read-pattern
	  (function
	   (lambda () (interactive)
	     (sirup-read-pattern (events-to-keys (this-command-keys)))))))

(defun sirup-read-pattern-unread ()
  (interactive)
  (setq unread-command-char last-command-char)
  (sirup-read-pattern))
(if (boundp 'last-command-event)
    (fset 'sirup-read-pattern-unread
	  (function
	   (lambda () (interactive)
	     (setq unread-command-events
		   (cons last-command-event unread-command-events))
	     (sirup-read-pattern)))))

(defun sirup-read-pattern (&optional initial)
  (interactive)
  (sirup-lookup-pattern (read-string "Pattern: " initial)))

(defun sirup-index-to-type (index)
  (let ((entry (assq index sirup-index-type-table)))
    (or (and (eq sirup-server-implementation 'dserver)
	     (not (assq index sirup-index-available))
	     (cdr (cdr entry)))
	(car (cdr entry)))))

(defun sirup-lookup-pattern (pattern)
  (let ((index-regular-pattern (sirup-index-and-regular-pattern pattern)))
    (sirup-show-entries (sirup-index-to-type (car index-regular-pattern))
			(cdr index-regular-pattern)
			pattern)))

(defun sirup-show-entries (type pattern original-pattern)
  (sirup-open-dictionary)
  (if sirup-asynchronous-flag
      (ndtp-get-entries sirup-process type pattern nil nil
			(` (lambda (command)
			     (sirup-show-entries-callback
			      command '(, (current-buffer))
			      '(, original-pattern)))))
    (sirup-show-entries-callback
     (ndtp-get-entries sirup-process type pattern) (current-buffer)
     original-pattern)))

(defun sirup-delete-first-from-rest (list)
  (and list
       (cdr (prog1 list
	      (let ((first (car list)))
		(while (if (equal first (car (cdr list)))
			   (setcdr list (cdr (cdr list)))
			 (cdr (setq list (cdr list))))))))))
(if (fboundp 'delete)
    (fset 'sirup-delete-first-from-rest
	  (function
	   (lambda (list) (setcdr list (delete (car list) (cdr list)))))))

(defun sirup-delete-duplicates (list)
  (prog1 list
    (while list
      (setq list (sirup-delete-first-from-rest list)))))

(defun sirup-show-entries-callback (command buffer pattern)
  (if (eq (ndtp-command-status command) t)
      (if (null (ndtp-command-result command))
	  (message "Pattern `%s' not found." pattern)
	(set-buffer buffer)
	(let ((entries (sirup-delete-duplicates
			(ndtp-command-result command))))
	  (if (and (null (cdr entries)) sirup-show-unique-entry-immediately)
	      (progn
		(let (buffer-read-only)
		  (erase-buffer))
		(string-match "\n" (car entries))
		(sirup-show-body (substring (car entries) (match-end 0))))
	    (let ((number 1)
		  buffer-read-only entry)
	      (erase-buffer)
	      (widen)
	      (insert "Pattern: " pattern "\n\n")
	      (while entries
		(setq entry (car entries))
		(string-match "\n" entry)
		(insert (format "%2d. <" (prog1 number
					   (setq number (1+ number))))
			(substring entry (match-end 0)) ">\t")
		(ndtp-insert-and-decode-euc-jp
		 (substring entry 0 (match-beginning 0)))
		(insert ?\n)
		(setq entries (cdr entries)))
	      (run-hooks 'sirup-show-entries-hook))
	    (set-buffer-modified-p nil)
	    (sirup-show-buffer nil t
			       (save-excursion
				 (sirup-beginning-of-page)
				 (sirup-next-link nil t)
				 (point))))))))

(defun sirup-show-body (fno)
  (sirup-open-dictionary)
  (let ((parent-point (point)))
    (if (string-match "\\`0:" fno)
	;; should wait sirup-process if asynchronous
	(sirup-show-system-document (substring fno (match-end 0))
				    (current-buffer) parent-point)
      (if sirup-asynchronous-flag
	  (ndtp-get-body
	   sirup-process fno nil nil
	   (` (lambda (command)
		(sirup-show-body-callback
		 command '(, (current-buffer)) '(, parent-point)))))
	(sirup-show-body-callback
	 (ndtp-get-body sirup-process fno) (current-buffer) parent-point)))))

(defun sirup-show-body-callback (command buffer parent-point)
  (if (eq (ndtp-command-status command) t)
      (progn
	(set-buffer buffer)
	(widen)
	(goto-char parent-point)
	(let (buffer-read-only)
	  (sirup-end-of-page)
	  (if (not (eobp))
	      (forward-char -1))
	  (delete-region (point) (point-max))
	  (if (not (bobp))
	      (insert (format "\n\f%d\t[" parent-point)
		      (sirup-heading-around (1- parent-point)) "]\n\n"))
	  (ndtp-insert-and-decode-euc-jp (ndtp-command-result command))
	  (run-hooks 'sirup-show-body-hook))
	(set-buffer-modified-p nil)
	(sirup-show-buffer nil sirup-narrow-to-page-flag
			   (save-excursion
			     (sirup-beginning-of-page)
			     (if (/= (point) 1)
				 (progn (forward-line 2) (point))))))))

(defun sirup-insert-index (index-available)
  (let (entry)
    (while index-available
      (if (setq entry
		(assq (car (car index-available)) sirup-index-caption-table))
	  (progn
	    (insert ?\t (car (cdr entry)))
	    (if (cdr (cdr entry))
		(insert ?< (cdr (car index-available)) ":0>"))
	    (insert ?\n)))
      (setq index-available (cdr index-available)))))

(defun sirup-process-busy-p (process)
  (and process
       (eq (process-status process) 'open)
       (ndtp-busy-p sirup-process)))

(defun sirup-show-title ()
  (interactive)
  (if (sirup-process-busy-p sirup-process)
      (progn
	(message "Process %s is busy.  Waiting..."
		 (process-name sirup-process))
	(while (progn (accept-process-output sirup-process)
		      (sirup-process-busy-p sirup-process)))
	(message "")))
  (sirup-insert-title)
  (sirup-show-buffer nil t))

(defun sirup-insert-title ()
  (let (buffer-read-only)
    (erase-buffer)
    (insert "このバッファでは辞書`" sirup-dictionary
	    "'による検索ができます。検索の種類は以下の通りです。\n\n")
    (sirup-open-dictionary)
    (sirup-insert-index sirup-index-available)
    (insert "\n初めて使われる場合は以下の説明を参照してください。
(`C-i', `C-o' でリンク(<..:..>)位置にカーソルを移動後、`RET' で説明を見る。
 `C-t' (Title と覚える)でこの画面に戻る。)\n
    使いかた:
\t初級編<0:000>\n\t中級編<0:001>\n\t上級編<0:002>\n
    よくある質問と回答<0:fa9>
    変更履歴<0:added>\n
Sirup version " sirup-version
"\nCreated by YAMAMOTO Mitsuharu <mituharu@math.s.chiba-u.ac.jp>"))
  (set-buffer-modified-p nil)
  (run-hooks 'sirup-insert-title-hook))

(defun sirup-encode-to-euc-jp-array (string)
  (code-convert-string string '*internal* '*euc-japan*))
(cond ((boundp 'MULE))			; see above
      ((featurep 'mule)
       (if (string-match "XEmacs\\|Lucid" emacs-version)
	   (fset 'sirup-encode-to-euc-jp-array
		 (function
		  (lambda (string)
		    (vconcat
		     ;; (map 'char-int ...) may be needed in the future.
		     (encode-coding-string string 'euc-jp)))))
	 (fset 'sirup-encode-to-euc-jp-array
	       (function
		(lambda (string) (encode-coding-string string 'euc-jp))))))
      (t
       (fset 'sirup-encode-to-euc-jp-array
	     (function (lambda (string) string)))))

;;; At present XEmacs 20.3 coerces a character to an integer when
;;; comparing them with <, <=, =, /=, and so on.
(defun sirup-index-and-regular-pattern (pattern)
  (setq pattern (sirup-encode-to-euc-jp-array pattern))
  (let ((len (length pattern))
	(i 0) kanji kana alpha first char-list)
    (while (< i len)
      (let* ((c1 (aref pattern (prog1 i (setq i (1+ i)))))
	     (c2 (if (<= c1 127)
		     c1
		   (+ (* c1 256)
		      (aref pattern (prog1 i (setq i (1+ i))))))))
	(setq char-list
	      (cons
	       (cond ((or (= c1 ?*)
			  (= c2 41462)) ; `＊'
		      (cond ((= i (if (= c1 ?*) 1 2)) ; at beginning
			     (setq first t))
			    ((= i len)	; at end
			     (if first
				 (error "`*'は1個しか使えません。")))
			    (t
			     (error "`*'はパターンの端以外では使えません。")))
		      ?*)
		     ((and (= c1 ??)	; do nothing
			   (eq sirup-server-implementation 'dserver))
		      ??)
		     ((or (and (<= ?a c1) (<= c1 ?z))
			  (and (<= ?A c1) (<= c1 ?Z)))
		      (setq alpha t)
		      (+ c1 41856))	; a380
		     ((<= c1 127)
		      (error "検索に使えない文字`%c'が含まれています。" c1))
		     ((= c1 163)
		      (setq alpha t)
		      c2)
		     ((or (= c1 164)	; hirakana
			  (= c1 165))	; katakana
		      (setq kana t)
		      c2)
		     (t
		      (setq kanji t)
		      c2))
	       char-list))))
;;;    (if (eq od-dict-type 'EB)
;;;	(cond (kanji
;;;	       (error "漢字による検索はできません."))
;;;	      ((and kana alpha)
;;;	       (message
;;;		"仮名と英字が混ざっていますが, 仮名として検索を続けます."))))
    (setq len (or kana kanji))
    (cons (cond ((and len
		      (or (not kanji)
			  (eq sirup-server-implementation 'ndtpd)))
		 (if first 'BK 'IK))
		((or alpha
		     (and kanji
			  (eq sirup-server-implementation 'dserver)))
		 (if first 'BA 'IA))
		(t
		 (error "検索方法が決定できません。")))
	  (ndtp-decode-euc-jp-string
	   (mapconcat
	    (function
	     (lambda (c)
	       (cond ((<= c 127)
		      (char-to-string c))
		     ((and (not len)
			   (>= c 41921) ;  a3c1 `Ａ'
			   (<= c 41978)) ; a3fa `ｚ'
		      (char-to-string (- c 41856)))
		     (t
		      (format "%c%c" (/ c 256) (% c 256))))))
	    (if first char-list (nreverse char-list))
	    "")))))

(defconst sirup-alphabet-regexp "[A-Za-z]")

(defconst sirup-japanese-regexp (if (boundp 'NEMACS) "\\z" "\\cj"))

(defconst sirup-hiragana-regexp (if (boundp 'NEMACS) "\\ch\\|\\cH" "\\cH"))

(defconst sirup-katakana-regexp (if (boundp 'NEMACS) "\\ck\\|\\cK" "\\cK"))

(defconst sirup-japanese-word-constituent-regexp
  (cond ((boundp 'NEMACS)
	 "\\ca\\|\\ch\\|\\cH\\|\\ck\\|\\cK\\|\\cg\\|\\cr\\|\\cc\\|\\cC")
	((boundp 'MULE)
	 "\\se")
	(t
	 "\\sw")))

(defun sirup-looking-at-word-constituent ()
  (or (looking-at sirup-alphabet-regexp)
      (and (looking-at sirup-japanese-regexp)
	   (looking-at sirup-japanese-word-constituent-regexp))))

(defun sirup-word-at-point ()
  (save-excursion
    (let ((front (point))
	  (back (and (not (bolp)) (progn (backward-char) (point))))
	  case-fold-search)
      (while (not
	      (or (and (null front) (null back))
		  (and front
		       (progn
			 (goto-char front)
			 (or (sirup-looking-at-word-constituent)
			     (progn
			       (setq front
				     (and (not (eolp))
					  (progn (forward-char) (point))))
			       nil))))
		  (and back
		       (progn
			 (goto-char back)
			 (or (sirup-looking-at-word-constituent)
			     (progn
			       (setq back
				     (and (not (bolp))
					  (progn (backward-char) (point))))
			       nil)))))))
      (if (or front back)
	  (progn
	    (setq front
		  (cond ((looking-at sirup-alphabet-regexp)
			 sirup-alphabet-regexp)
			((looking-at sirup-hiragana-regexp)
			 sirup-hiragana-regexp)
			((looking-at sirup-katakana-regexp)
			 sirup-katakana-regexp)))
	    (if front
		(buffer-substring
		 (save-excursion
		   (while (and (not (bolp))
			       (progn (backward-char) (looking-at front))))
		   (if (not (looking-at front))
		       (forward-char))
		   (point))
		 (progn
		   (while (and (not (eolp))
			       (progn (forward-char) (looking-at front))))
		   (point)))
	      (if (not (looking-at "\\<"))
		  (backward-word 1))
	      (buffer-substring (point)
				(progn (forward-word 1) (point)))))))))

(provide 'sirup)

;;; sirup.el ends here
