;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: XIT
;;;                       Module: Window Pool Manager
;;;                       Version: 1.0
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Juergen Herczeg
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/utilities/window-pool-manager.lisp
;;; File Creation Date: 10/17/91 11:33:59
;;; Last Modification Time: 07/21/92 13:38:15
;;; Last Modification By: Juergen Herczeg
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;;__________________________________________________________________________
;;
;; window-pool-managers may be used to manage windows for reuse.
;; Instead of being destroyed, managed windows are stored in a window pool
;; for later use under an (indiviual) key.  There is an external key, by
;; which the window may be requested from the pool-manager (method
;; get-pool-window) and an internal key under which the window is stored
;; in the window-manager.  To this end two different ky transformations
;; may be specified (key-transformation and internal-key-transformation).
;;
;; The class window-pool-mixin asociates a window with a window-pool-manager.
;; Also for this class, the destroy method has been redefined.
;;
;; The window-creation-function defines how new windows are created
;; when there is no saved window in the pool.
;;
;; the before-enter-function and after-leave-function specify operations
;; to be performed before a window is saved or after it is retrieved for
;; reuse.
;;
;; Example:
;;
;; (defcontact my-managed-window (window-pool-mixin window-icon-mixin intel)
;;     ((window-pool-manager :initform *my-window-pool*)))
;;
;; (setq *my-window-pool*
;;    (make-instance 'window-pool-manager
;;      :key-transformation #'view-of
;;      :internal-key-transformation #'class-of
;;      :before-enter-function #'(lambda (window key)
;;				   (setf (contact-state window) :withdrawn))
;;      :after-leave-function #'(lambda (window key)
;;				   (setf (view-of window) key))
;;      :window-creation-function #'(lambda (my-key)
;;				    (make-window 'my-managed-window
;;						 :width 100 :height 100
;;						 :background "white"))))
;;
;; (setq my-window (get-pool-window *my-window-pool* 
;;                     (make-instance 'class-a))
;;
;; creates a new window of class my-managed-window and sets its view of
;; to the supplied application object of class class-a.
;;
;; (destroy my-window)
;;
;; sets the state of the window to :withdrawn and saves it in the
;; window-pool-manager under the key "class-a".
;; The same window may be retrieved for a new application object of the 
;; same class class-a. 
 
(in-package :xit)

;;;__________________________________________________________________________
;;;
;;;                      Window Pool Manager
;;;__________________________________________________________________________

(defclass window-pool-manager ()
  ((window-pool :initform nil
		:accessor window-pool)
   (key-transformation :initform #'identity
		       :accessor key-transformation
		       :initarg :key-transformation)
   (internal-key-transformation :initform #'identity
				:accessor internal-key-transformation
				:initarg :internal-key-transformation)
   (before-enter-function :initform nil
			  :accessor before-enter-function
			  :initarg :before-enter-function)
   (after-leave-function  :initform nil
			  :accessor after-leave-function
			  :initarg :after-leave-function)
   (window-creation-function :initform nil
			     :accessor window-creation-function
			     :initarg :window-creation-function)))

(defmethod get-pool-key ((self window-pool-manager) window)
  (with-slots (key-transformation) self
    (funcall key-transformation window)))

(defmethod get-internal-pool-key ((self window-pool-manager) key)
  (with-slots (internal-key-transformation) self
    (funcall internal-key-transformation key)))

(defmethod windows-for-internal-key ((self window-pool-manager) key)
  (with-slots (window-pool) self
    (cdr (assoc key window-pool))))

(defmethod (setf windows-for-internal-key)
    (new-list (self window-pool-manager) key)
  (with-slots (window-pool) self
    (if new-list
	(let ((entries (windows-for-internal-key self key)))
	  (if entries
	      (setf (cdr (assoc key window-pool)) new-list)
	    (setf window-pool
		(acons key new-list window-pool))))
      (setq window-pool (delete key window-pool :key #'car)))))

(defmethod windows-for-key ((self window-pool-manager) key)
  (windows-for-internal-key self (get-internal-pool-key self key)))

(defmethod (setf windows-for-key) (new-list (self window-pool-manager) key)
  (setf (windows-for-internal-key self (get-internal-pool-key self key)) new-list))

(defmethod add-pool-window ((self window-pool-manager) window)
  (with-slots (before-enter-function) self
    (let* ((key (get-pool-key self window))
	   (entries (windows-for-key self key)))
      (when before-enter-function
	(funcall before-enter-function window key))
      (setf (windows-for-key self key)
	  (cons window entries)))))

(defmethod get-pool-window ((self window-pool-manager) key)
  (with-slots (window-creation-function after-leave-function) self
    (let* ((entries (windows-for-key self key))
	   (window (if entries
		       (car entries)
		     (when window-creation-function
		       (let ((new-window
			      (funcall window-creation-function key)))
			 (setf (window-pool-manager new-window) self)
			 new-window)))))
      (when entries
	(setf (windows-for-key self key)
	    (cdr entries))
	(when after-leave-function
	  (funcall after-leave-function window key)))
      window)))
		     
(defmethod destroy-all-windows ((self window-pool-manager) &optional key)
  (with-slots (window-pool) self
    (if key
	(progn
	  (dolist (window (windows-for-key self key))
	    (setf (window-pool-manager window) nil)
	    (destroy window))
	  (setf (windows-for-key self key) nil))
      (progn
	(dolist (entry window-pool)
	  (dolist (window (cdr entry))
	    (setf (window-pool-manager window) nil)
	    (destroy window)))
	(setf window-pool nil)))))

;;;__________________________________________________________________________
;;;
;;;                      Window Pool Mixin
;;;__________________________________________________________________________

(defclass window-pool-mixin ()
  ((window-pool-manager :type (or null window-pool-manager)
			:initform nil
			:accessor window-pool-manager
			:initarg :window-pool-manager)))

(defmethod destroy :around ((self window-pool-mixin))
  (with-slots (window-pool-manager) self
    (if window-pool-manager
	(add-pool-window window-pool-manager self)
      (call-next-method))))
