;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: XIT
;;;                       Module: Intels
;;;                       (Version 1.0)
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Juergen Herczeg
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/kernel/intels.lisp
;;; File Creation Date: 6/23/89 10:31:37
;;; Last Modification Time: 08/03/92 15:30:20
;;; Last Modification By: Juergen Herczeg
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;; 02/07/1991 (Juergen) Class part-slots of class uniform-part-intel changed
;;;                      to part-options (this is what it actually means)
;;;
;;; 06/25/1991 (Juergen) The methods send-parts, setf-parts, broadcast, 
;;;                      broadcast-setf, set-parts-slots, and 
;;;                      broadcast-set-slot now return more "meaningful" 
;;;                      values.
;;; 12/19/1991 (Matthias) intel: replaced do-adjust-window-size by 
;;;                       adjusted-window-size
;;;
;;; 03/04/1992 (Juergen) new methods part-position and (setf part-position),
;;;                      which should be used instead of change-part-position
;;;
;;; 03/17/1992 (Juergen) part-class now is initialized to nil if not further
;;;                      specified.  Formerly, it was unbound.
;;;
;;; 08/03/1992 (Juergen) Optimized and bug-fixed initialize-instance :after
;;;                      for intels by using without-layouting
;;;_____________________________________________________________________________

(in-package :xit)

;_______________________________________________________________________________
;
;                                 INTEL
;_______________________________________________________________________________

;; An intel is a layouted interaction window that represents specific
;; interaction objects, e.g. icons, menus ...

(defcontact intel (interaction-window layouted-window)
  ()
  (:resources
   (inside-border :initform 2))
  (:documentation "Implements basic functionality of all compound interaction
                   objects, i.e. objects represented by windows having
                   subwindows (parts)."))

(defmethod initialize-instance :after ((self intel) &rest init-list &key parts)
  (declare (ignore init-list))
  (when parts
    (without-layouting self
      ;; initialize-instance for the intel and its parts may trigger
      ;; change-layout to be called for the intel (and thus its parent).
      ;; This is not useful here or, even worse, may cause errors for
      ;; for windows which are not fully initialized.     
     (dolist (part parts)
	(apply #'add-part self part))
      )))

(defmethod initialize-instance :around ((self intel) &rest init-list &key)
  (declare (ignore init-list))
  (call-next-method)
  (unless (composite-children self)
    (without-layouting self
		       (adjust-window-size self))))

(defgeneric add-part (intel &rest part-init-list &key &allow-other-keys)
  (:documentation "Function for incrementally adding a part to an intel"))

(defmethod add-part ((self intel) &rest part-init-list &key class)
  #+LISPM (setq part-init-list (copy-list part-init-list))
  (loop
    (unless (remf part-init-list :class) (return)))
  (apply #'make-window class :parent self
	 part-init-list))

(defmethod delete-part ((self intel) (part basic-contact))
  (destroy part))

(defmethod delete-part ((self intel) (part t))
  (send-parts self part #'destroy))

(defmethod part-position ((self interaction-window))
  (1+ (position self (parts (part-of self)) :test #'eq)))

(defmethod (setf part-position) (position (self interaction-window))
  (change-part-position self position)
  position)

(defmethod change-part-position ((self contact) position)
  (with-slots (parent) self
     (with-slots (children) parent
        (let ((new-position (min (max 1 position) (length children)))
	      (old-position (1+ (position self children :test #'eq)))
	      predecessor)
	  (unless (eq new-position old-position)
	    ; remove self from old position
	    (if (eq old-position 1)
		(progn
		  (setf (car children) (cadr children))
		  (setf (cdr children) (cddr children)))
	      (progn
		(setq predecessor (nthcdr (- old-position 2) children))
		(setf (cdr predecessor) (cddr predecessor))))
	    ; add self to new position
	    (if (eq new-position 1)
		(progn
		  (setf (cdr children) (cons (car children) (cdr children)))
		  (setf (car children) self))
	      (progn
		(setq predecessor (nthcdr (- new-position 2) children))
		(setf (cdr predecessor) (cons self (cdr predecessor)))))
	    (change-layout parent)))))) 

(defgeneric add-part-at (intel position &rest part-init-list &key &allow-other-keys)
  (:documentation "Adding a part to an intel at specified position"))

(defmethod add-part-at ((self intel) position &rest part-init-list &key class)
  (without-layouting self
   (let ((part (apply #'add-part self :class class part-init-list)))
     (change-part-position part position)
     part)))

(defmethod (setf parts) (new-parts (self intel))
  (with-final-layout self
    ;; final change-layout is needed if new-parts is ().
    (dolist (part (copy-list (parts self)))
      (delete-part self part))
    (dolist (part new-parts)
      (apply #'add-part self part))))

(defmethod (setf inside-border) :after (new-border (self intel))
  (declare (ignore new-border))
  (change-layout self))

(defmethod adjusted-window-size ((self intel))
  (multiple-value-bind (bbox-w bbox-h) (bounding-size self)
    (values (+ bbox-w (x-margins self))
	    (+ bbox-h (y-margins self)))))

;_______________________________________________________________________________
;
;                          PART ACCESS FOR INTELS
;_______________________________________________________________________________

(defmethod parts ((self intel) &optional part-name)
  (with-accessors ((children composite-children)) self
     (if part-name 
	 (remove-if-not #'(lambda (part) (eq (contact-name part) part-name))
		     children)
       children)))

(defmethod part ((self intel) value &key (key #'contact-name) (test #'eq))
  (find value (parts self)
	:key key
	:test test))

(defmethod part-with-identification ((self intel) identification
				     &key (test #'equal))
  (part self identification
	:key #'identification
	:test test))

(defmethod part-viewing ((self intel) object &key (test #'eq))
  (part self object
	:key #'view-of
	:test test))

(defmethod part* ((self intel) &rest name-list)
  (if name-list
      (let ((part (part self (first name-list))))
	(when part (apply #'part* part (rest name-list))))
    self))

(defmethod find-part ((self intel) test)
  (find-if test (parts self)))

(defmethod find-parts ((self intel) test)
  (remove-if-not test (parts self)))

;;;______________________________________________________________
;;;
;;; The following 6 methods should not be used any longer
;;; (may be removed in future versions) 02/01/1991 (Hubertus) 
;;;
(defmethod send-part ((self intel) part-name &rest message)
  (apply (car message) (part self part-name) (cdr message)))

(defmethod send-part-with-identification ((self intel) object &rest message)
  (apply (car message) (part-with-identification self object) (cdr message)))

(defmethod send-part-viewing ((self intel) object &rest message)
  (apply (car message) (part-viewing self object) (cdr message)))

(defmethod setf-part ((self intel) part-name accessor value)
  (eval `(setf (,accessor (part ',self ',part-name)) ',value)))

(defmethod setf-part-with-identification ((self intel) object accessor value)
  (eval `(setf (,accessor (part-with-identification ',self ',object)) ',value)))

(defmethod setf-part-viewing ((self intel) object accessor value)
  (eval `(setf (,accessor (part-viewing ',self ',object)) ',value)))

;;;
;;;______________________________________________________________________


(defmethod send-parts ((self intel) part-name &rest message)
  (mapcar #'(lambda (part)
	      (apply (car message) part (cdr message)))
	  (copy-list (parts self part-name))
	  ; list is copied, because message might be destructive
	  ))

(defmethod setf-parts ((self intel) part-name accessor value)
  (eval `(dolist (part (parts ',self ',part-name))
	   (setf (,accessor part) ',value)))
  value)

(defmethod broadcast ((self intel) &rest message)
  (mapcar #'(lambda (part)
	      (apply (car message) part (cdr message)))
	  (copy-list (parts self))
	  ; list is copied, because message might be destructive
	  ))

(defmethod broadcast-setf ((self intel) accessor value)
  (eval `(dolist (part (copy-list (parts ',self)))
	; list is copied, because accessor might trigger destructive operation
	   (setf (,accessor part) ',value)))
  value)

(defmethod set-parts-slots ((self intel) part-name slot value)
  (dolist (part (parts self part-name))
    (setf (slot-value part slot) value))
  value)

(defmethod broadcast-set-slot ((self intel) slot value)
  (dolist (part (parts self))
    (setf (slot-value part slot) value))
  value)

;_______________________________________________________________________________
;
;                             UNIFORM PART INTEL
;_______________________________________________________________________________

;; A uniform-part-intel is an intel whose parts are instances of same class, 
;; e.g. menus.
;; The parts may have slots initialized from their part-of

(defcontact uniform-part-intel (intel)
  ((part-class :initform nil :reader part-class :initarg :part-class)
   (part-options :allocation :class :initform nil))
  (:documentation "intel with parts having the same part class"))

(defmethod add-part :around ((self uniform-part-intel) &rest part-init-list &key class)
  ;; 03/04/1991 (Matthias) obsolete?, cf. primary method
  ;;#+LISPM (setq part-init-list (copy-list part-init-list))
  ;;(remf part-init-list :class)
  (with-slots (part-class part-options) self
    (let ((parent-slot-init-list
	   (mapcan #'(lambda (slot)
		       (list (cdr slot) (funcall (car slot) self)))
		   part-options)))
     (apply #'call-next-method self
	     :class (or class part-class)
	     (append part-init-list parent-slot-init-list)))))

(defmethod add-part-at ((self uniform-part-intel) position
			&rest part-init-list &key class)
  (without-layouting self
   (let ((part (if class
		   (apply #'add-part self :class class part-init-list)
		 (apply #'add-part self part-init-list))))
     (change-part-position part position)
     part)))