;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;__________________________________________________________________________
;;;
;;;                       System: XIT
;;;                       Module: Shrinkable-Window
;;;                       (Version 1.0)
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Juergen Herczeg
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/kernel/shrinkable-window.lisp
;;; File Creation Date: 6/23/89 10:31:37
;;; Last Modification Time: 12/10/92 15:55:27
;;; Last Modification By: Juergen Herczeg
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;; 03/18/1992 (Juergen) New value :if-needed allowed for slot window-icon
;;;
;;;__________________________________________________________________________

(in-package :xit)

;; window-icon-mixin is introduced as mixin-class for shrinkable windows
;; that have an associated "icon" (slot window-icon). This "icon" may be
;; any (interaction-) window, which by default gets expanded to the 
;; shrinkable window by single left button click.
;;
;; The window-icon may be specified by one of the following forms:
;;
;;     <window object>
;;     <window-class-name>
;;     (<window-class-name> <initform1> <initform2> ...)
;;     :default   the window icon is computed by method get-default-icon at 
;;                initialization time
;;     :if-needed the window icon is computed by method get-default-icon  
;;                when it is needed first
   
;; If the shrinkable window is initialized as :mapped, the icon will
;; :managed, otherwise it will be :mapped

;; If no parent is specified for the icon the parent is taken from the
;; window.  The position of the icon (and window) is determined by the
;; slot window-icon-pos:
;;   nil            take the values specified or the defaults
;;   :window        initialize the icon position to the window position
;;   :icon-constrained     always position the icon at the window position
;;   :window-constrained   always position the window at the icon position
;;   :constrained   put the icon at the window position when shrinking, and
;;                  put the window at the icon position when expanding
;____________________________________________________________________________

(defclass window-icon-mixin ()
  ((window-icon :type (or null (member :default :if-needed) interaction-window)
		:initform :default
		:accessor window-icon)
   (window-icon-pos :type (or null (member :window
					   :window-constrained
					   :icon-constrained
					   :constrained))
		    :initform nil
		    :accessor window-icon-pos
		    :initarg :window-icon-pos))
  (:documentation "Class window-icon-mixin associates an interaction object
                   with an icon which represents it."))

(defmethod initialize-instance :after ((self window-icon-mixin)
				       &rest init-list &key window-icon)
   (declare (ignore init-list))
   (with-slots ((icon window-icon) window-icon-pos parent x y state) self
      (let ((icon-descr (or window-icon icon)))
	(when icon-descr
	  (if (eq icon-descr :if-needed)
	      (setf icon :if-needed)
	    (progn
	      (setf icon
		  (if ;; (typep icon-descr 'basic-contact)
		      ;; cleaner version
		      (window-p icon-descr)
		      (progn
			(when (and (eq state :mapped)
				   (eq (contact-state icon-descr) :mapped))
			  (setf (contact-state icon-descr) :managed))
			icon-descr)
		    (let ((icon-inits (when (listp icon-descr)
					(cdr icon-descr))))
		      (when (eq state :mapped)
			(setq icon-inits (list* :state :managed icon-inits)))
		      (case window-icon-pos
			((:window :icon-constrained)
			 (setq icon-inits (list* :x x :y y icon-inits))))
		      (unless (getf icon-inits :parent)
			(setq icon-inits (list* :parent parent icon-inits)))
		      (if (eq icon-descr :default)
			  (apply #'get-default-icon self icon-inits)
			(let* ((icon-class (if (listp icon-descr)
					       (car icon-descr)
					     icon-descr)))
			  (apply #'make-window icon-class icon-inits))))))
	  (init-icon self icon)))))))

(defmethod init-icon ((self window-icon-mixin) ignore)
  ;; nothing to do
  )

(defmethod init-icon ((self window-icon-mixin) (icon interaction-window))
  (setf (view-of icon) self)
  (unless (reactivity-entry icon :select)
    (change-reactivity icon :select
		       "Expand to window"
		       '(call :view-of expand))))
 
(defmethod expanded? ((self window-icon-mixin))
  (eq (contact-state self) :mapped))

(defmethod destroy :after ((self window-icon-mixin))
  (with-slots (window-icon) self
    (when (and window-icon
	       (typep window-icon 'contact))
      (destroy window-icon))))

(defmethod get-default-icon  ((self window-icon-mixin) &rest init-list)
  ())   ; redefined in file icons
        ; to be changed by specific window classes 

(defmethod set-default-icon ((self window-icon-mixin))
  (with-slots (parent x y state window-icon-pos window-icon) self
    (let ((icon-inits `(:parent ,parent)))
      (when (eq state :mapped)
	(setq icon-inits (list* :state :managed icon-inits)))
      (case window-icon-pos
	((:window :icon-constrained)
	 (setq icon-inits (list* :x x :y y icon-inits))))
      (setf window-icon (apply #'get-default-icon self icon-inits))
      (init-icon self window-icon)
      window-icon)))

(defmethod animate-rectangles ((self contact) steps x-start y-start
			       w-start h-start x-end y-end w-end h-end)
  (let* ((display (contact-display self))
	 (steps (if (> steps 1) steps 2))
	 (x-offset (/ (- x-end x-start) steps))
	 (y-offset (/ (- y-end y-start) steps))
	 (w-offset (/ (- w-end w-start) steps))
	 (h-offset (/ (- h-end h-start) steps)))
    (using-gcontext (gc :drawable self :subwindow-mode :include-inferiors
			:function BOOLE-XOR :foreground *inversion-pixel*
			:line-width 2)
       (dotimes (s (- steps 1) t)
	 (draw-rectangle-inside self gc
				(round (+ x-start (* s x-offset)))
				(round (+ y-start (* s y-offset)))
				(round (+ w-start (* s w-offset)))
				(round (+ h-start (* s h-offset))))
	 (display-force-output display)
	 (draw-rectangle-inside self gc
				(round (+ x-start (* s x-offset)))
				(round (+ y-start (* s y-offset)))
				(round (+ w-start (* s w-offset)))
				(round (+ h-start (* s h-offset)))))
       (draw-rectangle-inside self gc x-end y-end w-end h-end)
       (display-force-output display)
       (draw-rectangle-inside self gc x-end y-end w-end h-end))))

(defparameter *animation-steps* 30)

(defmethod expanding-feedback ((self window-icon-mixin))
  (with-slots (window-icon (my-parent parent)
               x y (my-width width) (my-height height)) self
    (let ((animation-window
	   (or (toplevel-window self)
	       (contact-root self))))
      (multiple-value-bind (my-x my-y)
	  (contact-translate my-parent x y animation-window)
	(with-slots ((ic-parent parent) x y (ic-width width) (ic-height height))
	    window-icon
	  (multiple-value-bind (ic-x ic-y)
	      (translate-coordinates ic-parent x y animation-window)
	    (animate-rectangles animation-window
				*animation-steps*
				ic-x ic-y ic-width ic-height
				my-x my-y my-width my-height)))))))
			       
                 
(defmethod shrinking-feedback ((self window-icon-mixin))
  (with-slots (window-icon (my-parent parent)
               x y (my-width width) (my-height height)) self
    (let ((animation-window
	   (or (toplevel-window self)
	       (contact-root self))))
      (multiple-value-bind (my-x my-y)
	  (contact-translate my-parent x y animation-window)
	(with-slots ((ic-parent parent) x y (ic-width width) (ic-height height))
	    window-icon
	  (multiple-value-bind (ic-x ic-y)
	      (translate-coordinates ic-parent x y animation-window)
	    (animate-rectangles
	     animation-window
	     *animation-steps*
	     my-x my-y my-width my-height
	     ic-x ic-y ic-width ic-height)))))))
								

(defmethod expand ((self window-icon-mixin))
  (unless (expanded? self)
    (with-slots (window-icon window-icon-pos) self
      (case window-icon
	((:default :if-needed) (set-default-icon self)))
      (when window-icon
	(with-slots (x y) window-icon
	  (setf (contact-state window-icon) :managed)
	  (case window-icon-pos
	    ((:window-constrained :constrained)
	     (move-window self x y)))
	  (expanding-feedback self)))
      (change-priority self :above)
      (setf (contact-state self) :mapped))))

(defmethod shrink ((self window-icon-mixin))
  (when (expanded? self)
    (with-slots (window-icon window-icon-pos x y) self
       (case window-icon
	((:default :if-needed) (set-default-icon self)))
      (when window-icon
	 (case window-icon-pos
	   ((:icon-constrained :constrained)
	    (move-window window-icon x y)))
	 (setf (contact-state self) :withdrawn) ;; :managed does not work for shells
	 (shrinking-feedback self)
	 (setf (contact-state window-icon) :mapped)))))

(defmethod shrink-or-expand ((self window-icon-mixin))
  (if (expanded? self)
      (shrink self)
    (expand self)))
