;; eldic.el
;; CD-ROM 辞書検索用 emacs-lisp file.
;;  for 研究社 英和、和英中辞典 電子ブック版
;;  ver 0.01    by. T.Nakamura(nakamura@acl.mech.tohoku.ac.jp)
;;

;; 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 versions 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 ELDIC, see the file COPYING.  If not, write to the Free
;; Software Foundation Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

;;dic process の状態を示す変数
(defvar dic-process nil)
 
;; 英和辞書検索
(defun lookup-edic (word)
  (interactive (rdo-read-with-default "English word: "
                                      (rdo-get-word-at-point)))
  (if dic-process
      (if (or (not (eq (process-status dic-process) 'run))
              (yes-or-no-p "A dic process is running; kill it? "))
          (condition-case ()
              (let ((comp-proc dic-process))
                (interrupt-process comp-proc)
                (sit-for 1)
                (delete-process comp-proc))
            (error nil))
        (error "Cannot have two dic processes")))
  (setq dic-process nil)
; この exec dic -D1 を都合のよいように書き換えれば他の辞書にも
; 応用が効くかと思われます。
  (setq dic-process (start-process "compilation" "*EJdic*"
                       shell-file-name
                       "-c" (concat "exec dic -D1 " word)))
  (with-output-to-temp-buffer "*EJdic*")
  (let (save-excursion (set-buffer "*EJdic*")))
  (set-process-sentinel dic-process 'dic-sentinel)

  (let* ((outbuf (process-buffer dic-process))
	 (outwin (get-buffer-window outbuf)))
    (if (eq outbuf (current-buffer))
        (goto-char (point-max)))
    (save-excursion
      (set-buffer outbuf)
      (buffer-flush-undo outbuf)
      (let ((start (save-excursion (set-buffer outbuf) (point-min))))
        (set-window-start outwin start)
        (or (eq outwin (selected-window))
            (set-window-point outwin start)))
      (fundamental-mode)
      (setq mode-name "dictionary")
      ;; Make log buffer's mode line show process state
      (setq mode-line-process '(": %s")))))
;
;和英辞書検索
(defun lookup-jdic (word)
  (interactive (rdo-read-with-default "Japanese(かな) word: "
                                      nil ))
  (if dic-process
      (if (or (not (eq (process-status dic-process) 'run))
              (yes-or-no-p "A dic process is running; kill it? "))
          (condition-case ()
              (let ((comp-proc dic-process))
                (interrupt-process comp-proc)
                (sit-for 1)
                (delete-process comp-proc))
            (error nil))
        (error "Cannot have two dic processes")))
  (setq dic-process nil)
; この exec dic -D2 を都合のよいように書き換えれば他の辞書にも
; 応用が効くかと思われます。
  (setq dic-process (start-process "compilation" "*JEdic*"
                       shell-file-name
                       "-c" (concat "exec dic -D2 " word)))
  (with-output-to-temp-buffer "*JEdic*")
  (let (save-excursion (set-buffer "*JEdic*")))
  (set-process-sentinel dic-process 'dic-sentinel)

  (let* ((outbuf (process-buffer dic-process))
	 (outwin (get-buffer-window outbuf)))
    (if (eq outbuf (current-buffer))
        (goto-char (point-max)))
    (save-excursion
      (set-buffer outbuf)
      (buffer-flush-undo outbuf)
      (let ((start (save-excursion (set-buffer outbuf) (point-min))))
        (set-window-start outwin start)
        (or (eq outwin (selected-window))
            (set-window-point outwin start)))
      (fundamental-mode)
      (setq mode-name "dictionary")
      ;; Make log buffer's mode line show process state
      (setq mode-line-process '(": %s")))))
;
; 
; process 監視（注：$(NEMACSLISP)/lisp/compile.el から引用
(defun dic-sentinel (proc msg)
  (cond ((null (buffer-name (process-buffer proc)))
         ;; buffer killed
         (set-process-buffer proc nil))
        ((memq (process-status proc) '(signal exit))
         (let* ((obuf (current-buffer))
                omax opoint)
           ;; save-excursion isn't the right thing if
           ;;  process-buffer is current-buffer
           (unwind-protect
               (progn
                 ;; Write something in *compilation* and hack its mode line,
                 (set-buffer (process-buffer proc))
                 (setq omax (point-max) opoint (point))
                 (goto-char (point-max))
                 (insert ?\n mode-name " " msg)
                 (forward-char -1)
                 (insert " at "
                         (substring (current-time-string) 0 -5))
                 (forward-char 1)
                 (setq mode-line-process
                       (concat ": "
                               (symbol-name (process-status proc))))
                 ;; If buffer and mode line will show that the process
                 ;; is dead, we can delete it now.  Otherwise it
                 ;; will stay around until M-x list-processes.
                 (delete-process proc))
             (setq dic-process nil)
             ;; Force mode line redisplay soon
             (set-buffer-modified-p (buffer-modified-p)))
           (if (and opoint (< opoint omax))
               (goto-char opoint))
           (set-buffer obuf)))))
;; 引数表示
(defun rdo-read-with-default (prompt default)
  (let* ((spec (read-string
                (if default                                                                        (format "%s(default %s) " prompt default)
                  prompt))))
    (list (if (equal spec "")
              default
            spec))))

;; カーソル位置の単語の取得
(defun rdo-get-word-at-point ()
  (save-excursion
    (while (looking-at "\\sw\\|\\s_")
      (forward-char 1))
    (if (re-search-backward "\\sw\\|\\s_" nil t)
        (progn (forward-char 1)
               (buffer-substring (point)
                                 (progn (forward-sexp -1)
                                        (while (looking-at "\\s'")
                                          (forward-char 1))
                                        (point))))
      nil)))