;;; 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 'static)
  (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
  (require 'wid-edit)
  (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
;;; 
(defconst liece-splash-image
  (eval-when-compile
    (cond
     ((and (fboundp 'image-type-available-p)
	   (image-type-available-p 'xpm))
      (let ((file (expand-file-name "liece.xpm" default-directory)))
	(if (file-exists-p file)
	    (list 'image
		  :type 'xpm
		  :data (with-temp-buffer
			  (insert-file-contents-as-binary file)
			  (buffer-string))))))
     ((fboundp 'set-face-stipple)
      (let ((file (expand-file-name "liece.xbm" default-directory)))
	(if (file-exists-p file)
	    (bitmap-stipple-xbm-file-to-stipple file)))))))

(defun liece-emacs-splash (&optional arg)
  (interactive "P")
  (let* ((font (cdr (assq 'font (frame-parameters))))
	 (liece-insert-environment-version nil)
	 config buffer pixel-width pixel-height)
    (unwind-protect
	(progn
	  (setq config (current-window-configuration))
	  (save-excursion
	    (switch-to-buffer (setq buffer (liece-get-buffer-create
					    (concat (if arg "*" " *")
						    (liece-version) "*"))))
	    (erase-buffer)
	    (static-cond
	     ((and (fboundp 'image-type-available-p)
		   (image-type-available-p 'xpm))
	      (with-temp-buffer
		(insert (plist-get (cdr liece-splash-image) :data))
		(goto-char (point-min))
		(skip-syntax-forward "^\"")
		(when (looking-at "\"[ \t]*\\([0-9]+\\)[ \t]*\\([0-9]+\\)")
		  (setq pixel-width (string-to-int (match-string 1))
			pixel-height (string-to-int (match-string 2)))))
	      (insert (make-string (max 0 (/ (- (frame-height)
						(/ pixel-height
						   (frame-char-height)))
					     2))
				   ?\n)
		      (make-string (max 0 (/ (- (frame-width)
						(/ pixel-width
						   (frame-char-width)))
					     2))
				   ?\ ))
	      (static-if (condition-case nil
			     (progn (insert-image '(image)) nil)
			   (wrong-number-of-arguments t))
		  (insert-image liece-splash-image "x")
		(insert-image liece-splash-image))
	      (insert "\n"))
	     (t
	      (bitmap-stipple-insert-pixmap liece-splash-image 'center)))
	    (insert "\n")
	    (insert-char ?\  (max 0 (/ (- (window-width)
					  (length (liece-version)))
				       2)))
	    (put-text-property (point) (prog2 (insert (liece-version))(point)
					 (insert "\n"))
			       'face 'underline))
	  (or arg (sit-for 2)))
      (unless arg
	(kill-buffer buffer)
	(set-window-configuration config)))))

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

(defun liece-emacs-create-mode-line-image ()
  (static-when (fboundp 'image-type-available-p)
    (let ((file (liece-locate-icon-file
		 (static-cond
		  ((image-type-available-p 'xpm)
		   "liece-pointer.xpm")
		  ((image-type-available-p 'xbm)
		   "liece-pointer.xbm")))))
      (and file (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)
    (if (and (stringp id) (string-match "^Liece:" id)
	     (setq liece-mode-line-image
		   (liece-emacs-create-mode-line-image)))
	(progn
	  (add-text-properties 0 (length id)
			       (list 'display
				     liece-mode-line-image
				     'rear-nonsticky (list 'display))
			       id)
	  (setcar line id)))
    line))

(fset 'liece-mode-line-buffer-identification
      'liece-emacs-mode-line-buffer-identification)

;;; @ nick buffer decoration
;;; 
(defun liece-emacs-create-nick-image (file)
  (static-when (and (fboundp 'image-type-available-p)
		    (image-type-available-p 'xpm))
    (let ((file (liece-locate-icon-file file)))
      (and file (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)))))))

(add-hook 'liece-nick-insert-hook 'liece-emacs-nick-image-region)
(add-hook 'liece-nick-replace-hook 'liece-emacs-nick-image-region)
       
(and liece-splash-image window-system
     (liece-emacs-splash))

(provide 'liece-emacs)

;;; liece-emacs.el ends here