;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: XIT
;;;                       Module: MULTIMEDIA
;;;                       Version: 1.0
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Matthias Ressel
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/kernel/images.lisp
;;; File Creation Date: 11/22/91 15:19:20
;;; Last Modification Time: 08/04/92 11:49:43
;;; Last Modification By: Matthias Ressel
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;; 11/25/1991 (Hubertus)  Fixed various minor bugs
;;;_____________________________________________________________________________

(in-package :xit)

;;; Application functions

(add-open-display-hook 'extend-bitmap-extensions)

(defun extend-bitmap-extensions (display)
  (declare (special *bitmap-extensions*))
  ;;; 11/25/1991 (Hubertus) don't forget to remove "xpm" extensions
  ;; for non-color displays
  (if (color-display-p display)
      (pushnew "xpm" *bitmap-extensions* :test #'equalp)
    (setf *bitmap-extensions*
	(delete "xpm" *bitmap-extensions* :test #'equalp))))
    

(defun image-symbol (image-name &optional name)
  (declare (special *bitmap-prefix*))
  (intern (if name
	      name
	    (concatenate 'string *bitmap-prefix*
			 (string-upcase image-name)))
			     ;; we have to intern in CLUE package because
			     ;; stringable-value looks up symbols there.
	  (find-package "CLUE")))
			       
(defmethod defcolorimage-from-file ((self contact) filename &optional name)
  "Defines new image to be read from file. Returns two values: the image and
   a colormap."
  (let ((file (find-file filename *bitmap-directory* *bitmap-extensions*))
	(bitmap-name (image-symbol filename name)))
    (when file
      (multiple-value-bind (type width height)
	  (type-of-image-file file)
	(declare (ignore width))
      (case type
	(:xpm
	 (let ((window (if (realized-p self) self
			 (contact-root self))))
	   (with-progress-indicator (:ticks height)
		(multiple-value-bind (image colormap)
		    (read-pixmap-file file window)
		  (new-image bitmap-name image colormap)
		  (values image colormap)))))
	(:xbm (new-image bitmap-name (read-bitmap-file file) nil)))))))

(defun defimage-from-file (filename &optional name)
  "Returns new image read from file. "
  (let ((file (find-file filename *bitmap-directory* *bitmap-extensions*))
	(bitmap-name (image-symbol filename name)))
    (when file
      (case (type-of-image-file file)
	(:xpm nil)
	(:xbm (new-image bitmap-name (read-bitmap-file file) nil))))))

(defun new-image (name image colormap)                 ; image is to be cached in *bitmap-images* 
  (declare (special cluei::*bitmap-images*))  ; under name
  (when (symbolp name)
    (when (and (typep (get name 'colormap) '(or null colormap))
	       (typep colormap 'colormap))
      (setf (get name 'colormap) colormap))
    (when (and (or (not (boundp name))
		   (typep (symbol-value name) 'image))
	       (typep image 'image))
      ;; this cache is no longer used in CLUE 7.20 (access is tru symbol's value!)
      (pushnew name cluei::*bitmap-images*)
      (set name image))))

(defmethod write-contact-image ((self contact) pathname &key region name
			   verbose)
  "Writes the window contents of SELF to a file named PATHNAME. When REGION is given, it must be either t (then you may specify a region interactively with the mouse) or an object of type region. By default the whole window will be scanned."
  (case region
    ((nil) (setq region (region 0 0
					(contact-width self)
					(contact-height self))))
    ((t) 
     (setq region (specify-region-with-mouse (toplevel-window self)
					     :confine-to self))))
  (when (region-p region)
      (let ((image (get-drawable-image self :x (region-x region)
					       :y (region-y region)
					       :width (region-w region)
					       :height (region-h region))))
       (with-progress-indicator (:ticks (region-h region))
	  (write-pixmap-file pathname image (window-colormap self) :name name
			  :verbose verbose)))))

(defun get-drawable-image (drawable &key (x 0) (y 0)
			       (width (drawable-width drawable))
			       (height (drawable-height drawable)))
  "Returns two values: the image from the given region of a drawable in 
image-z format and optionally a visual-info."
  (get-image drawable :x x :y y :width width :height height
	     :format :z-pixmap :result-type 'image-z))


