;;; liece-emacs.el --- FSF Emacs specific routines.
;; Copyright (C) 1999 Daiki Ueno

;; Author: Daiki Ueno <ueno@unixuser.org>
;; Created: 1999-08-21
;; Keywords: emulation

;; This file is part of Liece.

;; 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 GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.


;;; Commentary:
;; 

;;; Code:

(eval-when-compile
  (require 'liece-compat)
  (require 'liece-vars))

(eval-when-compile (ignore-errors (require 'image)))

(require 'derived)

(eval-and-compile
  (autoload 'bitmap-stipple-xbm-file-to-stipple "bitmap-stipple")
  (autoload 'bitmap-stipple-insert-pixmap "bitmap-stipple"))

;;; @ widget emulation
;;; 
(defvar liece-widget-keymap nil)

(unless liece-widget-keymap
  (setq liece-widget-keymap (copy-keymap widget-keymap))
  (substitute-key-definition
   'widget-button-click 'liece-widget-button-click
   liece-widget-keymap)
  (define-key liece-widget-keymap [mouse-3]
    'liece-widget-button-click))

(defun liece-emacs-widget-convert-button (type from to &rest args)
  (apply 'widget-convert-button type from to args)
  (let ((map (copy-keymap liece-widget-keymap)))
    (set-keymap-parent map (current-local-map))
    (overlay-put (make-overlay from to) 'local-map map)))

(defun liece-emacs-widget-button-click (event)
  (interactive "e")
  (let* ((window (posn-window (event-start event)))
	 (point (window-point window))
	 (buffer (window-buffer window)))
    (with-current-buffer buffer
      (unwind-protect
	  (progn
	    (goto-char (widget-event-point event))
	    (cond
	     ((widget-at (point)))
	     ((> (point) (save-excursion
			   (widget-forward 0)
			   (point)))
	      (widget-backward 0))
	     ((< (point) (save-excursion
			   (widget-backward 0)
			   (point)))
	      (widget-forward 0)))
	    (call-interactively (function widget-button-click)))
	(if (windowp (setq window (get-buffer-window buffer)))
	    (set-window-point window point))))))

(fset 'liece-widget-convert-button
      'liece-emacs-widget-convert-button)
(fset 'liece-widget-button-click
      'liece-emacs-widget-button-click)

;;; @ startup splash
;;; 
(defvar liece-splash-image
  (eval-when-compile
    (let ((file (expand-file-name "liece.xpm" default-directory)))
      (if (file-exists-p file)
	  (with-temp-buffer
	    (insert-file-contents-as-binary file)
	    (buffer-string))))))

(defun liece-emacs-splash-with-image ()
  (or (eq (car-safe liece-splash-image) 'image)
      (setq liece-splash-image
	    (create-image liece-splash-image 'xpm 'data)))
  (setq cursor-type nil)
  (when liece-splash-image
    (let ((image-size (image-size liece-splash-image)))
      (insert (make-string (max 0 (/ (- (window-height)
					(floor (cdr image-size)))
				     2))
			   ?\n))
      (make-string (max 0 (/ (- (window-width)
				(floor (car image-size)))
			     2))
		   ?\ )
      (insert-image liece-splash-image))))

(defun liece-emacs-splash-with-stipple ()
  (bitmap-stipple-insert-pixmap
   (eval-when-compile
     (let ((file (expand-file-name "liece.xbm" default-directory)))
       (if (file-exists-p file)
	   (bitmap-stipple-xbm-file-to-stipple file))))
   'center))

(defvar liece-splash-buffer nil)

(defvar liece-emacs-splash-function nil)

(defun liece-emacs-splash (&optional arg)
  (interactive "P")
  (unless (and liece-splash-buffer (buffer-live-p liece-splash-buffer))
    (let ((liece-insert-environment-version nil))
      (save-excursion
	(setq liece-splash-buffer (generate-new-buffer
				   (concat (if arg "*" " *")
					   (liece-version) "*")))
	(push liece-splash-buffer liece-buffer-list)
	(set-buffer liece-splash-buffer)
	(erase-buffer)
	(funcall liece-emacs-splash-function)
	(insert-char ?\  (max 0 (/ (- (window-width)
				      (length (liece-version)))
				   2)))
	(put-text-property (point) (prog2 (insert (liece-version))(point)
				     (insert "\n"))
			   'face 'underline))))
  (if arg
      (switch-to-buffer liece-splash-buffer)
    (save-window-excursion
      (switch-to-buffer liece-splash-buffer)
      (sit-for 2))))

;;; @ modeline decoration
;;; 
(defvar liece-mode-line-image nil)

(defun liece-emacs-create-mode-line-image ()
  (let ((file (liece-locate-icon-file "liece-pointer.xpm")))
    (if (file-exists-p file)
	(create-image file nil nil :ascent 99))))

(defun liece-emacs-mode-line-buffer-identification (line)
  (let ((id (copy-sequence (car line))) image)
      (or liece-mode-line-image
	  (setq liece-mode-line-image (liece-emacs-create-mode-line-image)))
      (when (and liece-mode-line-image
		 (stringp id) (string-match "^Liece:" id))
	(add-text-properties 0 (length id)
			     (list 'display
				   liece-mode-line-image
				   'rear-nonsticky (list 'display))
			     id)
	(setcar line id))
      line))

;;; @ nick buffer decoration
;;; 
(defun liece-emacs-create-nick-image (file)
  (let ((file (liece-locate-icon-file file)))
    (if (file-exists-p file)
	(create-image file nil nil :ascent 99))))

(defun liece-emacs-nick-image-region (start end)
  (save-excursion
    (goto-char start)
    (beginning-of-line)
    (setq start (point))

    (goto-char end)
    (beginning-of-line 2)
    (setq end (point))
    
    (save-restriction
      (narrow-to-region start end)
      (let ((buffer-read-only nil)
	    (inhibit-read-only t)
	    (case-fold-search nil)
	    mark image)
	(dolist (entry liece-nick-image-alist)
	  (setq mark (car entry)
		image (cdr entry))
	  (if (stringp image)
	      (setq image
		    (setcdr entry (liece-emacs-create-nick-image image))))
	  (goto-char start)
	  (while (not (eobp))
	    (when (eq (char-after) mark)
	      (add-text-properties (point) (1+ (point))
				   (list 'display
					 image
					 'rear-nonsticky (list 'display))))
	    (beginning-of-line 2)))))))

;;; @ unread mark
;;; 
(defun liece-emacs-unread-mark (chnl)
  (if liece-display-unread-mark
      (with-current-buffer liece-channel-list-buffer
        (let ((buffer-read-only nil))
	  (goto-char (point-min))
	  (when (re-search-forward (concat "^ ?[0-9]+: " chnl "$") nil t)
            (goto-char (match-end 0))
	    (insert (concat " " liece-channel-unread-character)))))))

(defun liece-emacs-read-mark (chnl)
  (if liece-display-unread-mark
      (with-current-buffer liece-channel-list-buffer
        (let ((buffer-read-only nil))
	  (goto-char (point-min))
	  (when (re-search-forward
		 (concat "^ ?[0-9]+: " chnl " "
			 liece-channel-unread-character "$") nil t)
            (goto-char (- (match-end 0) 2))
	    (delete-char 2))))))

(defun liece-emacs-redisplay-unread-mark ()
  (if liece-display-unread-mark
      (dolist (chnl liece-channel-unread-list)
        (liece-emacs-unread-mark chnl))))

(if (and (fboundp 'image-type-available-p)
	 (and (display-color-p)
	      (image-type-available-p 'xpm)))
    (progn
      (fset 'liece-mode-line-buffer-identification
	    'liece-emacs-mode-line-buffer-identification)
      (setq liece-emacs-splash-function #'liece-emacs-splash-with-image)
      (add-hook 'liece-nick-insert-hook 'liece-emacs-nick-image-region)
      (add-hook 'liece-nick-replace-hook 'liece-emacs-nick-image-region))
  (fset 'liece-mode-line-buffer-identification 'identity)
  (setq liece-emacs-splash-function #'liece-emacs-splash-with-stipple))

(when (and (not liece-inhibit-startup-message) window-system)
  (liece-emacs-splash))

(fset 'liece-redisplay-unread-mark 'liece-emacs-redisplay-unread-mark)
(add-hook 'liece-channel-unread-functions 'liece-emacs-unread-mark)
(add-hook 'liece-channel-read-functions 'liece-emacs-read-mark)

(provide 'liece-emacs)

;;; liece-emacs.el ends here