;;; -*- encoding:shift_jis-dos; tab-width:4; -*-
;;; wdic-fpw-pkg.el --- Lookup package for FreePWING version of WDIC

;; Copyright (C) 2003, Satomi I.
;; $Id: wdic-fpw-pkg.el 1.0.0.3 2004/08/25 06:52:16 satomii Exp $

;; This file is NOT a part of Lookup.

;; 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.

(require 'regexp-opt)

(or (fboundp 'browse-url)
	(autoload 'browse-url "browse-url" nil t))

(defgroup wdic-fpw nil
  "Lookup package for FreePWING version of WDIC."
  :group 'lookup-agents)

(defcustom wdic-fpw-line-prefix-strings
  '("◇" "→" "▼" "▽" "＠" "★" "◆"
	;; word information in a wdic-fpw1.3c dictionary.
	"分類: " "読み: " "発音: " "外語: ")
  "*A list of strings that should be treated as \"bullet\"s."
  :group 'wdic-fpw
  :type '(repeat 'string))

(defcustom wdic-fpw-url-regexp
  "^▽\\(\\(ftp\\|https?\\|news\\|telnet\\)://[\x21-\x7e]+\\)"
  "*Regular expression that matches an url reference.
If one or more sub expressions exist, the first one (match-string 1)
is used as the actual url."
  :group 'wdic-fpw
  :type 'regexp)

(defcustom wdic-fpw-browser-function 'browse-url
  "*Function for browsing a url reference.
The function is called with one argument, the url."
  :group 'wdic-fpw
  :type 'function)

(defface wdic-fpw-url-face
  '((((class color) (background dark)) (:foreground "cyan"))
	(((class color) (background light)) (:foreground "dodger blue")))
  "*Face used to highlight url references."
  :group 'wdic-fpw)

(defvar wdic-fpw-url-map
  (let ((map (make-sparse-keymap)))
	(define-key map "\C-m" 'wdic-fpw-follow-url)
	(if (featurep 'xemacs)
		(define-key map 'button2 'wdic-fpw-mouse-follow)
	  (define-key map [mouse-2] 'wdic-fpw-mouse-follow))
	map))

(defun wdic-fpw-arrange-images (entry)
  (let ((ndeb-image-caption-format "%s"))
	(ndeb-arrange-xbm entry)
	(ndeb-arrange-bmp entry)
	(ndeb-arrange-jpeg entry)))

(defun wdic-fpw-arrange-url (entry)
  (let ((keymap (if (or (featurep 'xemacs)
						(< emacs-major-version 21))
					'local-map
				  'keymap)))
	(while (re-search-forward wdic-fpw-url-regexp nil t)
	  (setq subexp (if (< 2 (length (match-data))) 1 0))
	  (add-text-properties (match-beginning subexp)
						   (match-end subexp)
						   (list 'face 'wdic-fpw-url-face
								 'mouse-face 'highlight
								 'wdic-url (match-string subexp)
								 'lookup-tab-stop t
								 keymap wdic-fpw-url-map)))))

(defun wdic-fpw-arrange-fill-lines (entry)
  (let ((regexp (regexp-opt wdic-fpw-line-prefix-strings))
		(fill-adapt (and (boundp 'filladapt-mode) filladapt-mode))
		(fill-column (if (integerp lookup-fill-column)
						 lookup-fill-column
					   (round (* (window-width) lookup-fill-column))))
		fill-prefix beg end)
	(if fill-adapt (filladapt-mode -1))
	(while (not (eobp))
	  (setq beg (point))
	  (end-of-line)
	  (when (< fill-column (current-column))
		(setq end (point))
		(goto-char beg)
		(setq fill-prefix (if (looking-at regexp)
							  (make-string (string-width (match-string 0)) ? )
							""))
		(save-restriction
		  (narrow-to-region beg end)
		  (fill-region beg end)
		  (unless (string= "" fill-prefix)
			(goto-char (point-min))
			(forward-line 1)
			(while (not (eobp))
			  (if (looking-at fill-prefix)
				  (set-text-properties (point) (match-end 0) nil))
			  (forward-line 1)))
		  (goto-char (point-max))))
	  (forward-line 1))
	(if fill-adapt (filladapt-mode 1))))

(defun wdic-fpw-follow-url ()
  (interactive)
  (let ((url (get-text-property (point) 'wdic-url)))
	(if url (funcall wdic-fpw-browser-function url)
	  (error "No url at point"))))

(defun wdic-fpw-mouse-follow (e)
  (interactive "e")
  (mouse-set-point e)
  (wdic-fpw-follow-url))

(when (and (boundp 'lookup-package-agent)
		   lookup-package-agent)
  (condition-case nil
	  (require lookup-package-agent)
	(error nil))
  (let ((remove-list '(ndeb-arrange-xbm
					   ndeb-arrange-bmp
					   ndeb-arrange-jpeg
					   ndeb-arrange-fill-lines
					   lookup-arrange-fill-lines))
		(arrange-list (copy-sequence (get lookup-package-agent :arranges))))
	(while remove-list
	  (setq arrange-list (delq (car remove-list) arrange-list)
			remove-list (cdr remove-list)))
	(setq lookup-package-agent-options
		  (list (cons :arranges `(wdic-fpw-arrange-images
								  ,@arrange-list
								  wdic-fpw-arrange-url
								  wdic-fpw-arrange-fill-lines))))))

;;; wdic-fpw-pkg.el ends here