;;; lookup-sound.el --- Lookup sound extender
;; Copyright (C) 2007 Kazuhiro Ito <kzhr@d1.dion.ne.jp>

;; Author: Kazuhiro Ito <kzhr@d1.dion.ne.jp>

;; lookup-sound.el 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.

;; lookuip-sound.el 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.

;;; Code:

(require 'lookup)

(defconst lookup-sound-version "0.1")

;;;
;;; Customizable variables
;;;

(defgroup lookup-sound nil
  "Lookup sound extender."
  :group 'lookup)


(defcustom lookup-sound-follow-functions
  '(("\\.wav$" lookup-sound-follow-with-play-sound-file)
    (nil "fiber"))
  "A list of arrange functions for playing sound. Each element is a list consist of regexp for filename, and symbol of function or string or list of strings for external program."
  :type '(repeat (list (choice :tag "filename" regexp (const nil))
		       (choice (function :tag "function")
			       (string :tag "program")
			       (cons :format "%v"
				     :tag "program with args"
				     (string :tag "link-program")
				     (repeat :tag "parameters")
				     ))))
  :group 'lookup-sound)

(defcustom lookup-sound-follow-from-entry nil
"A string or a vector of symbols and characters meaning a sequence of keystrokes and events for `lookup-entry-sound-follow'. If nil no keystrokes are assigned."
:type '(choice (const nil) (string :tag "Key"))
:group 'lookup-sound)

(defface lookup-sound-caption-face
  '((((class color) (background light)) (:foreground "Green4"))
    (((class color) (background dark)) (:foreground "GreenYellow")))
  "Face used to highlight the caption of a sound."
  :group 'lookup-sound
  :group 'lookup-faces)


;;;
;;; Internal variables
;;;

(defvar lookup-sound-link-map nil
  "Keymap for lookup sound links.")

(defconst lookup-sound-file-extensions
  '("wav" "mp3" "ogg" "au" "aiff" "aif"))

(defconst lookup-sound-file-extensions-regexp
  (concat "\\.\\("
	  (mapconcat (lambda (arg) (regexp-quote arg))
		     lookup-sound-file-extensions "\\|")
	  "\\)$"))
  

;;;
;;; Internal functions
;;;

(defun lookup-sound-initialize ()
  "Initialize lookup sound entender."
  (unless lookup-sound-link-map
    (setq lookup-sound-link-map (copy-keymap lookup-content-mode-map))
    (define-key lookup-sound-link-map "\C-m" 'lookup-sound-follow)
    (if (featurep 'xemacs)
	(define-key lookup-sound-link-map 'button2 'lookup-sound-mouse-follow)
      (define-key lookup-sound-link-map [mouse-2] 'lookup-sound-mouse-follow))))

(defun lookup-sound-set-link (start end face target)
  (add-text-properties start end
		       (list 
			(if (< emacs-major-version 21) 'local-map
			  'keymap)
			lookup-sound-link-map
			'face (or face 'lookup-reference-face)
			'mouse-face 'highlight
			'help-echo "mouse-2: play sound."
			'lookup-tab-stop t
			'sound target)))

(defun lookup-sound-get-link (&optional pos)
  (get-text-property (or pos (point)) 'sound))


;;;
;;; Link functions
;;;

(defun lookup-entry-sound-follow (&optional num)
  (interactive)
  (let ((dictionary (lookup-entry-dictionary
		     (lookup-entry-current-line-entry)))
	autoplay)
    (unless (lookup-entry-content-visible-p)
      (when (setq autoplay
		  (lookup-dictionary-option dictionary ':snd-autoplay))
	(lookup-set-dictionary-option
	 (lookup-dictionary-id dictionary) ':snd-autoplay nil))
      (lookup-entry-display-content)
      (when autoplay
	(lookup-set-dictionary-option
	 (lookup-dictionary-id dictionary) ':snd-autoplay autoplay)))
    (with-current-buffer lookup-content-buffer
      (save-excursion
	(goto-char (point-min))
	(unless (numberp num) (setq num 1))
	(let (point)
	  (catch 'loop
	    (while (setq point
			 (or (and (eq (point) (point-min))
				  (lookup-sound-get-link (point-min))
				  (point-min))
			     (next-single-property-change (point) 'sound)))
	      (goto-char point)
	      (when (eq 0 (setq num (1- num)))
		(lookup-sound-follow)
		(throw 'loop t))
	      (next-single-property-change (point) 'sound))
	    (error "No sound linkin content.")))))))

(defun lookup-sound-mouse-follow (event)
  "Play sound you click on."
  (interactive "e")
  (mouse-set-point event)
  (lookup-sound-follow))

(defun lookup-sound-follow ()
  (interactive)
  (let ((target (lookup-sound-get-link (point)))
	(params lookup-sound-follow-functions)
	param fn)
    (when target
      (catch ':done
	(while params
	  (setq param (car params))
	  (setq fn (nth 1 param))
	  (when (or (null (car param))
		    (string-match (car param) target))
	    (if (symbolp fn)
		(funcall fn target)
	      (when (stringp fn)
		(setq fn (list fn)))
	      (apply 'start-process " *lookup-sound-links*" nil (car fn)
		     target (cdr fn)))
	    (throw  ':done t))
	  (setq params (cdr params)))
	(error "No correspoding function.")))))

(defun lookup-sound-follow-with-play-sound-file (file)
  (play-sound-file file))


;;;
;;; Arrange functions
;;;

(defun lookup-sound-arrange-english (entry)
  (let* ((dictionary (lookup-entry-dictionary entry))
	 (directory (lookup-dictionary-option dictionary ':sound t))
	 heading files base point)
    (when (and directory (re-search-forward "^[a-zA-Z<][^\t \n]*" nil t))
      (setq heading (match-string 0))
      (with-temp-buffer
	(insert-string heading)
	(while (re-search-backward "<[^>]+>" nil t)
	  (replace-match "." nil t))
	(goto-char (point-min))
	(while (re-search-forward "[^A-Za-z.]+" nil t)
	  (replace-match "" nil t))
	(setq heading (downcase (buffer-string))))
      (setq base (expand-file-name (substring heading 0 1) directory))
      (setq files 
	    (directory-files base nil
			     (concat "^"
				     heading
				     ;; ".*"
				     lookup-sound-file-extensions-regexp)
			     t))
      (end-of-line)
      (while files
	(insert-string " ")
	(setq point (point))
	(insert-string (or (and (string-match "^\\(.+\\)\\.[a-zA-Z0-9]+$"
					      (car files))
				(match-string 1 (car files)))
			   "[音声]"))
	(lookup-sound-set-link point (point) 'lookup-sound-caption-face
			       (expand-file-name (car files) base))
	(setq files (cdr files))))))


;;;
;;; Setup
;;;

(eval-after-load "lookup-content" '(lookup-sound-initialize))

(when lookup-sound-follow-from-entry
  (eval-after-load "lookup-entry"
    '(define-key lookup-entry-mode-map lookup-sound-follow-from-entry
       (function lookup-entry-sound-follow))))

(provide 'lookup-sound)

;;; lookup-sound.el ends here