;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: OPAL; Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;         The Garnet User Interface Development Environment.      ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This code was written as part of the Garnet project at          ;;;
;;; Carnegie Mellon University, and has been placed in the public   ;;;
;;; domain.  If you are using this code or any part of Garnet,      ;;;
;;; please contact garnet@cs.cmu.edu to be put on the mailing list. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Add a component to an aggregadget and its instances.
;;; 
;;; Roger B. Dannenberg, 1990

#|
======================================================================
Change log:
  06/16/92 Andrew Mickish - New aggrelist and gadget methods (comments below)
  04/13/92 Brad VanderZanden - In :remove-component, do not remove
		an instance from an aggregadget if it is in the
		same aggregadget as the prototype.
  04/07/92 Andrew Mickish - Get-Local-Value ---> G-Local-Value
  03/25/92 Andrew Mickish - Get-Values ---> G-Value
  03/18/92 Andrew Mickish - Added condition to recursion in :remove-item method
  11/06/91 Edward Pervin - Made move-component a method.
  05/13/91 Edward Pervin - Add-item and remove-item had been defined
			in aggrelists.lisp.
  04/22/91 Andrew Mickish - Added Gadget-Add-Item and Gadget-Remove-Item
======================================================================
|#

#| Implementation details:

ADD-COMPONENT
Call add-local-component to add a new component at the prototype level.
Then go to each instance and recursively call add-component.
The insert point will be determined as follows:
  The default position is :front.
  If the position is :front/:tail, always insert at the :front.
  If the position is :back/:head, always insert at the :back.
  If the position is :behind/:before x, then
    if the instance aggregadget has a component that is an instance of x, then
      insert :behind the instance of x,
    otherwise if the instance aggregadget has a component y named xn, where
         x is :known-as xn, then
      insert :behind y
    otherwise, print a warning and insert at the :front  (the philosophy
      here is to err toward the front, making errors visible).
  If the position is :in-front/:after x, then the situation is analogous to
    :behind/:before.
  If the position is :at, then use :at and the same locator on each
    instance.

ADD-ITEM
Works just like add-component, but acts on :items slots.  If an
instance inherits its :item slot, then no local changes are made.
After the changes are made, notice-items-changed is called on each 
affected aggrelist.

|#

(in-package "OPAL" :use '("LISP" "KR"))
(export '(add-item remove-item add-interactor remove-interactor
	  take-default-component replace-item-prototype-object
	  gadget-add-item gadget-remove-item))

(defmacro add-interactor (schema &rest args)
  `(kr-send ,schema :add-interactor ,schema ,@args))

(defmacro remove-interactor (schema &rest args)
  `(kr-send ,schema :remove-interactor ,schema ,@args))

(defmacro take-default-component (schema &rest args)
  `(kr-send ,schema :take-default-component ,schema ,@args))

(defmacro replace-item-prototype-object (schema &rest args)
  `(kr-send ,schema :replace-item-prototype-object ,schema ,@args))

(define-method :add-component aggregadget (agg element &rest args)
  (let (where locator known-as)
    (cond ((eq (first args) :where)
	   (setq where (second args))
	   (setq locator (third args)))
	  ((first args)
	   (setq where (first args))
	   (setq locator (second args)))
	  (t
	   (setq where :tail)))

    ;; first add to prototype
    (add-local-component agg element where locator)

    ;; now do instances
    (setf known-as (g-local-value agg :known-as))
    (dolist (agg-instance (g-local-value agg :is-a-inv))
      (let ((element-instance (create-instance nil element))
	    (my-where where)
	    my-locator)
	(s-value element-instance :known-as known-as)
	(cond ((member where '(:front :tail :back :head)))
	      ((member where '(:behind :before :in-front :after))
	       ;; see if instance of locator is in agg-instance
	       (setf my-locator (find-locator-instance locator agg-instance))
	       (cond (my-locator) ; no problem
		     (t           ; put new component at the :front
		      (setf my-where :front))))
	      ;; otherwise this must be an :at
	      (t (setf my-locator locator)))
	(add-component agg-instance element-instance my-where my-locator)))))


(share-aggregadget-method :add-component)


;;; add-interactor -- add an interactor to prototype and instances
;;;
(define-method :add-interactor aggregadget (agg interactor)
  (let (known-as)
    ;; first add to prototype
    (add-local-interactor agg interactor)

    ;; now do instances
    (setf known-as (g-local-value agg :known-as))
    (dolist (agg-instance (g-local-value agg :is-a-inv))
      (let ((interactor-instance (create-instance nil interactor)))
	(s-value interactor-instance :known-as known-as)
	(add-interactor agg-instance interactor-instance)))))


(share-aggregadget-method :add-interactor)


;;; find-locator-instance -- find a locator in agg-instance that corresponds
;;;  to locator, presumed to be a member of the prototype of agg-instance
;;;
(defun find-locator-instance (locator agg-instance)
  (let ((agg-instance-components (g-local-value agg-instance :components))
	my-locator ; the locator we are trying to find
	known-as)  ; the :known-as field of locator

    ;; first look to see if locator has an instance in agg-instance
    (dolist (locator-instance (g-local-value locator :is-a-inv))
      (cond ((member locator-instance agg-instance-components)
	     (setf my-locator locator-instance)
	     (return))))

    ;; if that fails, then look for a component with the same name as locator
    (cond ((null my-locator)
	   (setf known-as (g-local-value locator :known-as))
	   (cond (known-as
		  (setf my-locator (g-local-value agg-instance known-as))))))

    ;; if no locator was found, then print a warning
    (cond ((null my-locator)
	   (warn "~A ~A in aggregate ~A~%~A ~A."
		 "No component corresponding to locator"
		 locator (g-value locator :parent)
		 "could be found for aggregate " agg-instance)))

    my-locator))


;;; remove-component -- remove a component from an aggregate and 
;;;   remove instances of the component from instances of the aggregate
;;;
;;; NOTE: we could do a quick-and-dirty job by just removing all instances
;;;  of component from their :parents, but the :parent might not be an
;;;  instance of agg, and we would not get components with the same name.
;;; To get everything but not too much, we will
;;;  (1) remove all instances from parents IF the parent :is-a this agg
;;;	 but the parent does not equal the agg.
;;;  (2) remove all parts that have the same name (:known-as) from the
;;;      aggregate's instances
;;;
(define-method :remove-component aggregadget (agg component &optional destroy?)
  (let ((component-instances (g-local-value component :is-a-inv))
	(known-as (g-local-value component :known-as)))
    (dolist (instance component-instances)
      (let ((parent (g-local-value instance :parent)))
        ;;; Condition used to be (is-a-p parent agg)
	(cond ((and (is-a-p parent agg) (not (eq parent agg)))
	       (remove-component parent instance destroy?)))))
    (cond (known-as
	   (dolist (agg-instance (g-local-value agg :is-a-inv))
	     (let ((component (g-local-value agg-instance known-as)))
	       (cond (component
		      (remove-component 
		       agg-instance component destroy?)))))))
    (remove-local-component agg component)
    (cond (destroy?
	   (destroy component)))))


(share-aggregadget-method :remove-component)


;;; remove-interactor
;;;
(define-method :remove-interactor aggregadget (agg interactor &optional destroy?)
  (let ((interactor-instances (g-local-value interactor :is-a-inv))
	(known-as (g-local-value interactor :known-as)))
    (dolist (instance interactor-instances)
      (let ((parent (g-local-value instance :operates-on)))
	(cond ((is-a-p parent agg)
	       (remove-interactor parent instance destroy?)))))
    (cond (known-as
	   (dolist (agg-instance (g-local-value agg :is-a-inv))
	     (let ((interactor (g-local-value agg-instance known-as)))
	       (cond (interactor
		      (remove-interactor 
		       agg-instance interactor destroy?)))))))
    (s-value interactor :active nil)
    (remove-local-interactor agg interactor)
    (cond (destroy?
	   (destroy interactor)))))


(share-aggregadget-method :remove-interactor)


;;; take-default-component -- remove a component and inherit default from
;;; prototype NOTICE that the argument is the NAME of the component to remove.
;;; An instance of the default prototype (if there is one) is placed :in-front
;;; of the appropriate component using add-component so that this change 
;;; propagates down to instances of agg.  If this component is not :in-front
;;; of anything, then :back is used.
;;;
(define-method :take-default-component aggregadget (agg name &optional destroy?)
  (let ((component (g-local-value agg name))
	(proto-agg (g-local-value agg :is-a))
	(where :in-front)
	locator)
    ;; if the component exists locally, remove it
    (cond (component
	   (remove-component agg component destroy?)))

    ;; find the new prototype component in the prototype aggregadget
    (setf component (g-local-value proto-agg name))

    (cond (component
	   ;; find the element before component to serve as a locator
	   (dolist (element (g-local-value proto-agg :components))
	     (if (eq element component) (return))
	     (setf locator element))))

    ;; map the locator into the current agg if possible, if there is no
    ;; locator, then the component is at the :back of the prototype; if
    ;; the locator has no instance in agg, then put the instance at the
    ;; :front.
    (cond (locator
	   (setf locator (find-locator-instance locator agg))
	   
	   (cond ((null locator)
		  (setf where :front)))) ; mapping failed, move to :front
	  (t 
	   (setf where :back))) ; null locator -> :back of aggregate

    ;; install a new prototype
    (cond (component
	   (add-component agg (create-instance nil component)
				where locator)))))


(share-aggregadget-method :take-default-component)


;;; replace the item-prototype slot and propagate the change to instances
;;; implementation: replace the top-most item-prototype and follow the
;;; agg's is-a-inv links to find instances whose item-prototypes are instances
;;; of the old item-prototype.  Replace these with instances of the new 
;;; item-prototype, and do this recursively down the instance tree.
;;; Now fix up the items: destroy all elements and call notice-items-changed
;;;
(define-method :replace-item-prototype-object aggrelist (agg item-proto)
  (let ((old-proto (g-value agg :item-prototype-object)))
    (dolist (agg-instance (g-local-value agg :is-a-inv))
      (cond ((is-a-p (g-value agg-instance :item-prototype-object) old-proto)
	     (replace-item-prototype-object agg-instance
					    (create-instance nil item-proto)))))
    (s-value agg :item-prototype-object item-proto)
    (remove-all-components agg)
    (s-value agg :number-of-comps 0)
    (notice-items-changed agg t)))

;;; Move-component method for aggregadgets.  Just does remove and add.
(define-method :move-component opal:aggregadget (agg comp &rest args)
  (let (where locator key)
    (multiple-value-setq (where locator key) (get-wheres args))
    (remove-component agg comp)
    (add-component agg comp where locator)))

(share-aggregadget-method :move-component)

;;; New Improved Aggrelist Methods
;;; Andrew Mickish  6/16/92
;;; 
;;; There are several differences between the implementation of these
;;; methods and the old aggrelist methods.
;;; 1)  Unlike the old methods, these make changes to instances in a
;;;     manner consistent with the rest of Garnet.  The old methods
;;;     s-valued a local :items list in all of an aggrelist's instances,
;;;     thereby destroying the natural inheritance scheme of the hierarchy.
;;;     In the new methods, the :items list is changed once in the prototype,
;;;     and then for each instance that inherits that :items list,
;;;     corresponding components are added or removed from the aggrelist.
;;; 2)  These methods handle component maintenance simultaneously with the
;;;     :items list, rather than just changing the :items list and calling
;;;     Notice-Items-Changed.
;;; 3)  Calling Notice-Items-Changed when there has been no real change to
;;;     the :items list is no longer harmless.  Notice-Items-Changed removes
;;;     all of the components of the aggrelist and generates all new ones.
;;;     This is necessary because of the new function-generated part feature
;;;     of aggregadgets -- you never know when the label of a text button
;;;     is incompatible with its corresponding item, so you have to throw it
;;;     away and make a new one just in case.  For this reason, you should
;;;     use the add-item, remove-item, etc. methods whenever possible.

(defun Add-The-Component (alist rank)
  (let* ((components (g-value alist :components))
	 (prev-component (if (> rank 0)
			     (nth (1- rank) components)))
	 (prototype (g-value alist :item-prototype-object)))
    (add-local-component alist
			 (create-instance NIL prototype
			   (:parent alist)
			   (:internally-parented T)
			   (:prev prev-component))
			 :at rank)))

(defun Recursive-Add-Component (alist rank)
  (Add-The-Component alist rank)
  (dolist (inst (g-value alist :is-a-inv))
    (unless (has-slot-p inst :items)
      (Recursive-Add-Component inst rank))))


(define-method :add-local-item opal:aggrelist (alist item &rest args)
  (let (where locator key)
    (multiple-value-setq (where locator key) (get-wheres args))
  
    (let* ((old-items (or (g-local-value alist :items)
			  (copy-list (g-value alist :items))))
	   (items (opal::insert-item item old-items where locator key))
	   (rank (position item items
			   :test #'(lambda (x y)
				     (equal x (funcall key y))))))
      (s-value alist :items items)
      (Add-The-Component alist rank))))


(define-method :add-item opal:aggrelist (alist item &rest args)
  (let (where locator key)
    (multiple-value-setq (where locator key) (get-wheres args))

    ;; first add to the prototype
    (add-local-item alist item where locator key)

    ;; now do instances
    (let ((rank (position item (g-value alist :items)
			  :test #'(lambda (x y)
				    (equal x (funcall key y))))))
      (dolist (inst (g-value alist :is-a-inv))
	(unless (has-slot-p inst :items)
	  ;; The instances have already gotten changes in the :items list
	  ;; through inheritance, so just add corresponding components
	  (Recursive-Add-Component inst rank)
	  ;; otherwise, :items is not inherited, so don't inherit changes
	  )))))

;; This function is always called with an aggrelist that is an instance of
;; another aggrelist.  So the :items slot is always inherited by ALIST.
;; Therefore, we can destroy the components without regard to the items, since
;; any item that is a component will not be a prototype item.
;;
(defun Recursive-Remove-Component (alist rank)
  (let ((component-to-destroy (nth rank (g-value alist :components))))
    (opal:remove-local-component alist component-to-destroy)
    (opal:destroy component-to-destroy))
  (dolist (inst (g-value alist :is-a-inv))
    (unless (has-slot-p inst :items)
      (Recursive-Remove-Component inst rank))))

(defun Is-In-Hierarchy (agg obj)
  (or (eq agg obj)
      (let ((obj-parent (g-value obj :parent)))
	(if obj-parent
	    (Is-In-Hierarchy agg obj-parent)))))

(define-method :remove-local-item opal:aggrelist
               (alist &optional item &key (key #'opal:no-func))
  (let* ((items (or (g-local-value alist :items)
		    (copy-list (g-value alist :items))))
	 (rank (if item
		   (position item items
			     :test #'(lambda (x y)
				       (equal x (funcall key y))))
		   (1- (length items)))))
    (cond (item
	   (s-value alist :items (opal::delete-elt item items key))
	   ;; Before destroying the component, remove the item from it
	   (let* ((comp-to-destroy (nth rank (g-value alist :components))))
	     (if (and (schema-p item)
		      (g-value item :parent)
		      (Is-In-Hierarchy comp-to-destroy item))
		 (let ((kr::*constants-disabled* T))
		   (remove-local-component (g-value item :parent) item)))
	     ;; Check to see if the comp-to-destroy still has a parent because
	     ;; if the item was itself the component, it was just removed
	     (if (g-value comp-to-destroy :parent)
		 (remove-local-component alist comp-to-destroy))
	     ;; Always remove aggrelist components before destroying them so
	     ;; that the aggrelist bookkeeping will be done.
	     (opal:destroy comp-to-destroy)))
	  (t
	   (if (numberp items)
	       (decf (g-value alist :items))
	       (s-value alist :items (nbutlast items)))
	   (let ((comp-to-destroy (nth rank (g-value alist :components))))
	     (remove-local-component alist comp-to-destroy)
	     (opal:destroy comp-to-destroy))))))

(define-method :remove-item opal:aggrelist
               (alist &optional item &key (key #'opal:no-func))
  (let* ((items (or (get-local-value alist :items)
		    (copy-list (g-value alist :items))))
	 (rank (if item
		   (position item items
			     :test #'(lambda (x y)
				       (equal x (funcall key y))))
		   ;; Can remove any item if none are specified
		   (1- (length items)))))
    ;; first remove from the prototype
    (remove-local-item alist item :key key)

    ;; now do instances
    (dolist (inst (g-value alist :is-a-inv))
      (unless (has-slot-p inst :items)
	;; The instances have already gotten changes in the :items list
	;; through inheritance, so just add corresponding components
	(Recursive-Remove-Component inst rank)
	;; otherwise, :items is not inherited, so don't inherit changes
	))))


(defun Gadget-Add-Local-Item (gadget item slot args)
  (let (where locator key)
    (multiple-value-setq (where locator key) (opal::get-wheres args))
    (let* ((old-items (or (g-local-value gadget :items)
			  (copy-list (g-value gadget :items))))
	   (items (opal::insert-item item old-items where locator key))
	   (rank (position item items
			   :test #'(lambda (x y)
				     (equal x (funcall key y))))))
      (s-value gadget :items items)
      (Add-The-Component (g-value gadget slot) rank))))  

(defun Gadget-Add-Item (gadget item slot args)
  (let (where locator key)
    (multiple-value-setq (where locator key) (opal::get-wheres args))
    ;; Do not pass SLOT to :add-local-item method -- the method knows it!
    (add-local-item gadget item where locator key)
    (let ((rank (position item (g-value gadget :items)
			  :test #'(lambda (x y)
				    (equal x (funcall key y))))))
      (dolist (inst (g-value gadget :is-a-inv))
	(unless (has-slot-p inst :items)
	  (Recursive-Add-Component (g-value inst slot) rank))))))

(defun Gadget-Remove-Local-Item (gadget item slot key)
  (let* ((items (or (g-local-value gadget :items)
		    (copy-list (g-value gadget :items))))
	 (rank (if item
		   (position item items
			     :test #'(lambda (x y)
				       (equal x (funcall key y))))
		   (1- (length items))))
	 (alist (g-value gadget slot)))
    ;; Gadgets always have lists for their :items values, so don't consider
    ;; the case where the value of :items is a number.
    (s-value gadget
	     :items
	     (opal::delete-elt (or item (nth rank items)) items key))
    ;; Before destroying the component, remove the item from it
    (let* ((comp-to-destroy (nth rank (g-value alist :components))))
      (if (and (schema-p item)
	       (g-value item :parent)
	       (Is-In-Hierarchy comp-to-destroy item))
	  (let ((kr::*constants-disabled* T))
	    (remove-local-component (g-value item :parent) item)))
      (if (g-value comp-to-destroy :parent)
	  (remove-local-component alist comp-to-destroy))
      (opal:destroy comp-to-destroy))))


(defun Gadget-Remove-Item (gadget item slot key)
  (let* ((items (g-value gadget :items))
	 (rank (if item
		   (position item items
			     :test #'(lambda (x y)
				       (equal x (funcall key y))))
		   (1- (length items)))))
    ;; first remove from the prototype
    (remove-local-item gadget item :key key)

    ;; now do instances
    (dolist (inst (g-value gadget :is-a-inv))
      (unless (has-slot-p inst :items)
	;; The instances have already gotten changes in the :items list
	;; through inheritance, so just add corresponding components
	(Recursive-Remove-Component (g-value inst slot) rank)
	;; otherwise, :items is not inherited, so don't inherit changes
	))))

(defun Motif-Buttons-Add-Local-Item (gadget item &rest args)
  (Gadget-Add-Local-Item gadget item :button-list args))
(defun Motif-Buttons-Add-Item (gadget item &rest args)
  (Gadget-Add-Item gadget item :button-list args))
(defun Motif-Buttons-Remove-Local-Item (gadget &optional item
					       &key (key #'opal:no-func))
  (Gadget-Remove-Local-Item gadget item :button-list key))
(defun Motif-Buttons-Remove-Item (gadget &optional item
					 &key (key #'opal:no-func))
  (Gadget-Remove-Item gadget item :button-list key))
(defun Motif-Buttons-Notice-Items-Changed (gadget &optional no-propagation)
  (opal:notice-items-changed (g-value gadget :button-list) no-propagation))

(define-method :change-item aggrelist (agg item n)
  (let ((items (g-value agg :items)))
    (if (or (>= n (length items))
	    (< n 0))
	(warn "Bad index in change-item: ~A" n)
	(progn
	  (remove-item agg (nth n items))
	  (add-item agg item :at n)))))


(define-method :remove-nth-item aggrelist (agg n)
  (let ((items (g-value agg :items)))
    (cond ((numberp items)  ;; just remove any item
	   (remove-item agg))
	  (t
	   (remove-item agg (nth n items))))))


(define-method :notice-items-changed opal:aggrelist
               (alist &optional no-propagation)
  ;; First do the prototype
  (dolist (c (copy-list (g-value alist :components)))
    (opal:remove-local-component alist c))
  (let* ((items (g-value alist :items))
	 (num-comps (if (numberp items) items (length items))))
    (Generate-Aggrelist-Components
     alist (g-value alist :item-prototype-object) num-comps))
  ;; Now do the instances
  (unless no-propagation
    (dolist (inst (g-value alist :is-a-inv))
      (unless (has-slot-p inst :items)
	(notice-items-changed inst)
	;; Otherwise, :items is not inherited, so don't inherit changes
	))))

;; The :notice-items-changed method for the gadgets with tic-marks
;; (gauge, v-slider, etc.)
;;
(defun tic-marks-changed (gadget &optional no-propagation)
  (declare (ignore no-propagation))
  (opal:notice-items-changed (g-value gadget :tic-marks)))


;;----------------------------------------------------------------------------
;;
;;  These functions are used to generate labels for the gadgets.  They are
;;  defined in this aggregadget file because they are used in several different
;;  gadget files.
;;
;;----------------------------------------------------------------------------

;;
;; These functions return objects that will be used directly
;;
(defun Single-Button-Get-Label (agg)
  (let ((item (g-value agg :string))
	(text-label-prototype (g-value agg :text-label-prototype))) 
    (cond
      ((schema-p item)
       (let ((new-label (if (g-value item :parent)
			    ;; The item has been used already --
			    ;; Use it as a prototype
			    (create-instance NIL item)
			    ;; Use the item itself
			    item))
	     (leftform (get-value text-label-prototype :left))
	     (topform (get-value text-label-prototype :top)))
	 ;; Automatically set the :left and :top of the label
	 (unless (is-a-p (get-local-value item :left) leftform)
	   (s-value new-label :left (formula leftform)))
	 (unless (is-a-p (get-local-value item :top) topform)
	   (s-value new-label :top (formula topform)))
	 new-label))
      (t (create-instance NIL text-label-prototype)))))

(defun Panel-Get-Label (agg)
  (let ((alist (g-value agg :parent)))
    (if alist  ;; Must check because the item-prototype
               ;; has no parent!
	(let ((item (nth (g-value agg :rank)
			 (g-value alist :items)))
	      (text-label-prototype (g-value alist :parent
					     :text-label-prototype)))
	  ;; Don't forget that item functions are allowed!
	  (if (consp item) (setq item (first item)))
	  ;; Don't forget that menus have item conversion functions!
	  (if (g-value alist :item-to-string-function)
	      (setf item (kr-send alist :item-to-string-function item)))
	  (cond
	    ((schema-p item)
	     (let ((new-label (if (g-value item :parent)
				  ;; The item has been used already --
				  ;; Use it as a prototype
				  (create-instance NIL item)
				  ;; Use the item itself
				  item))
		   (leftform (get-value text-label-prototype :left))
		   (topform (get-value text-label-prototype :top)))
	       ;; Automatically set the :left and :top of the label
	       (unless (is-a-p (get-local-value item :left) leftform)
		 (s-value new-label :left (formula leftform)))
	       (unless (is-a-p (get-local-value item :top) topform)
		 (s-value new-label :top (formula topform)))
	       new-label))
	    (t (create-instance NIL text-label-prototype))))
	;; Give the item-prototype a bogus part
	(create-instance NIL opal:null-object))))

