;;; srd-fpw.el --- supplement file for 『ランダムハウス英語辞典』
;; $Id: srd-fpw.el,v 1.10 2001/01/01 08:00:54 kazuhiko Exp $
;;
;; Copyright (C) 2000 Keisuke Nishida <kxn30@po.cwru.edu>
;; Copyright (C) 2000 Kazuhiko Shiozaki <kazuhiko@ring.gr.jp>
;; Copyright (C) 2000 Kazuyoshi KOREEDA <k_koreed@d2.dion.ne.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 version 2
;; of the License, 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, write to the Free Software Foundation,
;; Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

;;; Code:

(require 'lookup-package)
(require 'lookup-content)

; APEL が必要です。
(require 'poem)

(defvar srd-fpw-image-directory "/mnt/cdrom/DATA"
  "img.dat のある場所。")
(defvar srd-fpw-sound-directory "/mnt/cdrom/DATA"
  "srdra.bnd のある場所。")
(defvar srd-fpw-play-realaudio-process "realplay"
  "RealAudio を再生するプロセス名。nil なら再生しない。")
(defvar srd-fpw-display-image-process "display"
  "画像を表示するプロセス名。nil なら表示しない。")
(defvar srd-fpw-sound-without-notice nil
  "t なら検索と同時に音声を再生する。")
(defvar srd-image-inline t
  "nil なら (可能な場合でも) 画像をインライン表示しない。")
(defvar perl-process "perl"
  "perl のプロセス名。パスが通っていない場合はフルパスで記述すること。")

(defvar srd-fpw-tmp-dir temporary-file-directory "一時ファイルの作成場所")

(defconst srd-fpw-arranges
  '(lookup-arrange-gaijis
    srd-fpw-arrange-realaudio
    srd-fpw-arrange-images
    lookup-arrange-references
    lookup-arrange-default-headings
    lookup-arrange-fill-lines))

(defvar srd-fpw-dictionary-options
  (list (cons ':arranges srd-fpw-arranges)))

(defvar srd-fpw-process-file-alist '())

;; 
;; 元からある lookup-content-follow-linkの拡張
;; 
(unless (fboundp 'lookup-content-follow-link:old)
  (fset 'lookup-content-follow-link:old
	(symbol-function 'lookup-content-follow-link))
  (defun lookup-content-follow-link ()
    (interactive)
    (let ((action (get-text-property (point) 'action)))
      (if action 
	  (funcall action (point))
	(lookup-content-follow-link:old)))))

(defun srd-fpw-string-to-number (string)
  (let ((len (length string))
	(number 0) (i 0) c)
    (while (< i len)
      (setq number (* number 16))
      (setq c (aref string i))
      (cond
       ((and (<= ?0 c) (<= c ?9)) (setq number (+ number (- c ?0))))
       ((and (<= ?a c) (<= c ?f)) (setq number (+ number (- c ?a -10))))
       ((and (<= ?A c) (<= c ?F)) (setq number (+ number (- c ?A -10))))
       (t (setq i len)))
      (setq i (1+ i)))
    number))

(defun srd-fpw-arrange-images (entry)
  (while (re-search-forward
	  "<image=\\([^:]+\\):\\([^>]+\\)>" nil t)
    (let ((file "img.dat")
	  (offset (match-string 1))
	  (length (match-string 2))
	  (start (match-beginning 0))
	  (end (match-end 0)))
      ;; Find data file.
      (if (file-exists-p (expand-file-name file srd-fpw-image-directory))
	  (setq file (expand-file-name file srd-fpw-image-directory)))
      (if (and srd-fpw-image-inline
	       (featurep 'xemacs)
	       (eq window-system 'x))
	  (progn
	    (replace-match "\n")
	    (let ((offset (srd-fpw-string-to-number offset))
		  (length (srd-fpw-string-to-number length)))
	      (setq format-alist-bak format-alist)
	      (setq format-alist
		    '((image/jpeg "JPEG image" "\377\330\377\340\000\020JFIF"
				  image-decode-jpeg nil t image-mode)
		      (image/gif "GIF image" "GIF8[79]"
				 image-decode-gif nil t image-mode)
		      (image/png "Portable Network Graphics" "\211PNG"
				 image-decode-png nil t image-mode)
		      (image/x-xpm "XPM image" "/\\* XPM \\*/"
				   image-decode-xpm nil t image-mode)))
	      (insert-file-contents-internal file nil offset
					     (+ offset length))
	      (setq format-alist format-alist-bak)
	      ))
	(replace-match "→[画像]")
	(add-text-properties start 
			     (+ (length "→[画像]") start)
			     (list 'action 'srd-fpw-display-image
				   'file  file
				   'offset offset
				   'mouse-face 'highlight
				   'face 'lookup-reference-face
				   'length   length))))))

(defun srd-fpw-arrange-realaudio (entry)
  (while (re-search-forward
	  "<sound=\\([^:]+\\):\\([^>]+\\)>" nil t)
    (let ((file "srdra.bnd")
	  (offset (match-string 1))
	  (length (match-string 2))
	  (start (match-beginning 0))
	  (end (match-end 0)))
      ;; Find data file.
      (if (file-exists-p (expand-file-name file srd-fpw-sound-directory))
	  (setq file (expand-file-name file srd-fpw-sound-directory)))
      (if srd-fpw-sound-without-notice
	  (let* ((tmp-snd-file
		  (make-temp-name 
		   (expand-file-name "sr" temporary-file-directory)))
		 )
	    (if srd-fpw-play-realaudio-process
		(progn
		  (call-process
		   perl-process nil nil nil
		   (expand-file-name "extract-srd.pl" lookup-package-directory)
		   file offset length tmp-snd-file)
		  (srd-fpw-start-process srd-fpw-play-realaudio-process
					 nil tmp-snd-file t)))))
      (replace-match "→[音声]")
      (add-text-properties start 
			   (+ (length "→[音声]") start)
			   (list 'action 'srd-fpw-play-realaudio
				 'file  file
				 'offset offset
				 'mouse-face 'highlight
				 'face 'lookup-reference-face
				 'length   length)))))
;;
;; 外部プロセスを利用したイメージの表示
;;
(defun srd-fpw-display-image (pos)
  (let* ((file (get-text-property pos 'file))
	 (offset (get-text-property pos 'offset))
	 (length (get-text-property pos 'length))
	 (tmp-img-file (make-temp-name 
			(expand-file-name "sr" temporary-file-directory))))
    (if srd-fpw-display-image-process
	(progn
	  (call-process
	   perl-process nil nil nil
	   (expand-file-name "extract-srd.pl" lookup-package-directory)
	   file offset length tmp-img-file)
	  (srd-fpw-start-process
	   srd-fpw-display-image-process nil tmp-img-file t)))))
;;
;; 外部プロセスを利用した音声の再生
;;
(defun srd-fpw-play-realaudio (pos)
  (let* ((file (get-text-property pos 'file))
	 (offset (get-text-property pos 'offset))
	 (length (get-text-property pos 'length))
	 (tmp-snd-file (make-temp-name 
			(expand-file-name "sr" temporary-file-directory)))
	 )
    (if srd-fpw-play-realaudio-process
	(progn
	  (call-process
	   perl-process nil nil nil
	   (expand-file-name "extract-srd.pl" lookup-package-directory)
	   file offset length tmp-snd-file)
	  (srd-fpw-start-process
	   srd-fpw-play-realaudio-process nil tmp-snd-file t)))))
;;
;; 外部プロセスの呼出し
;; 
(defun srd-fpw-start-process (program options file &optional delete-file)
  (message "Starting %s ..." program)
  (let ((pro (apply (function start-process)
		    (format "*srd-fpw %s*" program)
		    nil
		    program
		    (append options (list file)))))
    (message "Starting %s ... done" program)
    (set-process-sentinel pro 'srd-fpw-start-process-sentinel)
    (setq srd-fpw-process-file-alist 
	  (cons (cons pro file) 
		(if delete-file 
		    srd-fpw-process-file-alist
		  nil)))))
;;
;; プロセスの状態が変更されたときにファイルを削除する。
;;
(defun srd-fpw-start-process-sentinel (process event)
  (let ((al (assoc process srd-fpw-process-file-alist)))
    (and (cdr al) (delete-file (cdr al)))
    (setq srd-fpw-process-file-alist 
	  (delete al srd-fpw-process-file-alist))))

(setq lookup-package-dictionary-options-alist
      (list (cons (cond ((eq lookup-package-agent 'ndtp) "srd-fpw/srd-fpw")
			((eq lookup-package-agent 'ndtp) "SRD-FPW/SRD-FPW")
			((eq lookup-package-agent 'ndeb) "srd-fpw")
			((eq lookup-package-agent 'ndeb) "SRD-FPW"))
		  srd-fpw-dictionary-options)))

;;; srd-fpw.el ends here
