;;; -*- 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. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;
;;; AGGRELISTS. This subclass of aggregates allow the easy creation of
;;; list-type objects, such as menus. Aggrelists features automatic
;;; and customizable horizontal or vertical layout, generation of
;;; items according to a prototype, and can be used with aggregadgets
;;; in order to create complex objects.

#|
======================================================================
Change log:
10/01/92 Andrew Mickish - Removed :update-slots list from aggrelist
 7/13/92 Andrew Mickish - Made :components and other slots constant in
           aggrelists created with a :parts list.
 7/08/92 Michael Sannella - Put dependency on :components in :max-width and
           :max-height formulas.
 6/17/92 Ed Pervin - Change :base-left, :base-top, :pre-align-top,
		:pre-align-left slots to contain coordinates relative
		to top, left of aggrelist, rather than absolute coordinates.
 6/17/92 Pedro Szekely - Made Dimensions-Fn more efficient
 6/09/92 Andrew Mickish - Removed reuse of old aggrelist components;
           Made Get-Wheres more robust.
 6/03/92 Andrew Mickish - Provided :parent and :internally-parented values
           in Create-Items to facilitate the generation of aggrelist parts
           by functions (the aggrelist component will have a parent before
           its :initialize method is invoked).
 4/09/92 Ed Pervin - Remove defvar of aggrelist.
 4/01/92 Ed Pervin - Add-item, change-item, and remove-item already defined
	   in opal/virtual-aggregates.lisp
 3/25/92 Andrew Mickish - Get-Values ---> G-Value
 3/18/92 Conrad Poelman - Added :width and :height aggrelist formulas
           that do not depend on the :left and :top of the aggrelist.
 3/18/92 Andrew Mickish - Removed recursion in :remove-local-item, added
           :free-comps list so old aggrelist components can be reused.
 3/16/92 Andrew Mickish - Moved *fixed-width/height-form* into aggrelist
           defintion; Fixed create-items to only create new maintenance
           formulas when necessary.
 3/10/92 Andrew Mickish - In :initialize method, declared :prev slot constant
           in each component generated from a :parts list
 2/07/92 Andrew Mickish - Converted calls to aggrelist maintenance functions
           (like base-left-fn, etc.) to be formulas.  Rewrote create-items
           to declare constant slots.  Added maybe-constant list.
 1/08/92 Andrew Mickish - Removed s-value of :prev-visible formula from
           add-local-component method, now set it directly in
           opal:graphical-object and opal:aggregate.  Changed :prev-visible
           function to use gv-local instead of gv.
10/10/91 Andrew Mickish - Fixed remove-local-component to remove the
           component corresponding to the item being removed.
 8/26/91 Pervin/VanDerZanden - In :destroy method for aggrelist, don't
           destroy item-prototype.
 6/14/91 Edward Pervin - Altered :change-item method to avoid return-from,
           since Lucid didn't like that.
 4/23/91 Andrew Mickish - Defined Tic-Marks-Changed
 4/22/91 Andrew Mickish - Added :notice-items-changed method for aggrelists
           and changed n-i-c function
 4/16/91 Andrew Mickish - Seperated :add-item method so that functions
           can be used in gadgets for add/remove-item methods
 4/11/91 Andrew Mickish - Set :parent slot in :add-local-component method
           so components can be reused
16/07/90 Dannenberg - Fixed destroy-me by adding NIL to call that
           destroys the item-prototype-object
16/07/90 Dannenberg - Changed compilation order: aggregadgets first
27/05/90 Dannenberg - added remove-nth-item method, remove-nth-component
           function
 8/05/90 Dannenberg - major mods for new version
11/03/89 Dario Guise fixed "form is being self-evaluated" warning
 9/28/89 Ed Pervin - Aggrelists can now have :interactors slot
 7/27/89 Philippe Marchal - optimized
 7/25/89 Philippe Marchal - removed the :aggrelist slot
 7/18/89 Philippe Marchal - added "add-item" and "remove-item"
 7/13/89 Philippe Marchal - Merged with Aggregitems
 7/13/89 Philippe Marchal - Reviewed, Changed to match KR V2.2
 5/24/89 David Kosbie  - Created
======================================================================
|#

(in-package "OPAL" :use '("KR" "LISP"))

(export '(aggrelist null-object add-local-item remove-local-item
	  notice-items-changed tic-marks-changed change-item
	  remove-nth-item remove-nth-component no-func))

;;;--------------------------------------------------------------------------
;;;
;;; Macros that allow the user to call methods as if they were functions.
;;;
;;;--------------------------------------------------------------------------

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

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

(defmacro remove-nth-item (schema n)
  `(kr-send ,schema :remove-nth-item ,schema ,n))

(defmacro remove-nth-component (schema n)
  `(kr-send ,schema :remove-nth-component ,schema ,n))

(defmacro notice-items-changed (agg &optional no-propagation)
  `(kr-send ,agg :notice-items-changed ,agg ,no-propagation))


;;;--------------------------------------------------------------------------
;;;
;;;      Utiltity functions and macros
;;;
;;;--------------------------------------------------------------------------


(defmacro num-or-zero (x)
	`(if (numberp ,x) ,x 0))

(defmacro destroy-constraints (schema &rest slots)
	`(dolist (slot ',slots) (destroy-constraint ,schema slot)))

(defmacro destroy-slots (schema &rest slots)
  	`(dolist (slot ',slots) (destroy-slot ,schema slot)))

;; This stops gv's throw on nil...
(defun my-gv (schema &rest slots)
  (dolist (slot slots)
     (unless (setq schema (gv schema slot)) (return-from my-gv nil)))
  schema)

;;; No-function: used as default value for the matching function.
(defun no-func (x) x)

;;;-------------------------------------------------------------------------
;;;
;;;    Formulas installed in the aggrelist and its components.  Aggrelists are
;;; defined with several default formulas in the slots :base-left, :base-top,
;;; etc.  These formulas are used to lay out the components of the aggrelist.
;;;
;;;-------------------------------------------------------------------------

;;;; The following formulas are installed in both the aggrelist itself,
;;;; *and* instances in each component
;;;;

;;; each-left-form computes the :left slot (in absolute coordinates)
;;;   The basic :left coordinate (relative to the parent aggrelist)
;;;   is determined from :pre-align-left, but if this is a fixed-width
;;;   field then the object may be aligned within the field
(defvar *each-left-form*
  (o-formula
   (let* ((pre-align-left (gvl :pre-align-left))
	  (my-agg-list     (gvl :parent))
	  (fixed-width  (gv my-agg-list :fixed-width)))
					;; Now handle alignment
    (+ (gv my-agg-list :left)
       (if fixed-width
	   (case (gv my-agg-list :h-align)
	       (:center
		   (+ pre-align-left
		      (floor (/ (- fixed-width (gvl :width)) 2))))
	       (:right
		   (+ pre-align-left (- fixed-width (gvl :width))))
	       (:left
		   pre-align-left))
	   pre-align-left)))))


;;; each-top-form computes the :top slot (in absolute coordinates)
;;;   The basic :top coordinate (relative to the parent aggrelist)
;;;   is determined from :pre-align-top, but if this is a fixed-height
;;;   field then the object may be aligned within the field
(defvar *each-top-form*
  (o-formula
   (let* ((pre-align-top (gvl :pre-align-top))
	  (my-agg-list     (gvl :parent))
	  (fixed-height (gv my-agg-list :fixed-height)))
					;; Now handle alignment
    (+ (gv my-agg-list :top)
       (if fixed-height
	   (case (gv my-agg-list :v-align)
	       (:center
		   (+ pre-align-top
		      (floor (/ (- fixed-height (gvl :height)) 2))))
	       (:bottom
		   (+ pre-align-top (- fixed-height (gvl :height))))
	       (:top
		   pre-align-top))
	   pre-align-top)))))


;;; base-left-form computes the nominal left coordinate of each object.
;;;   relative to the left coordinate of the entire aggrelist.
;;;   For horizontal lists, this is the (relative) left of the previously visible
;;;   object + the width (fixed or variable) + spacing.  For vertical
;;;   lists, this is just the (relative) left of the previously visible component.
;;;   base-left-form ignores breaks in rows/columns, but see
;;;   pre-align-left-form and each-left-form, which refine :base-left to
;;;   arrive at :left
;;;
(defvar *base-left-form*
  (o-formula
   (let ((prev-vis (gvl :prev-visible))
	(my-agg-list (gvl :parent)))
    (if prev-vis
	(if (eq (gv my-agg-list :direction) :horizontal)
	    (+  (gv prev-vis :pre-align-left)
		(or (gv my-agg-list :fixed-width) (gv prev-vis :width))
		(gv my-agg-list :h-spacing))
	    (gv prev-vis :pre-align-left))
	0))))


;;; base-top-form computes the value of the :base-top slot in each element
;;;    of the list.  See base-left-form for more details.
;;;
(defvar *base-top-form*
  (o-formula
   (let  ((prev-vis (gvl :prev-visible))
	  (my-agg-list (gvl :parent)))
	(if prev-vis
	    (if (eq (gv my-agg-list :direction) :vertical)
      		(+  (gv prev-vis :pre-align-top)
	     	    (or (gv my-agg-list :fixed-height) (gv prev-vis :height))
	 	    (gv my-agg-list :v-spacing))
      		(gv prev-vis :pre-align-top))
	    0))))


;;; pre-align-left-form computes the left coordinate of the field for this
;;;    component, relative to the entire aggrelist.  If there is no line
;;;    break, then the value will be :base-left; however, if there is a line
;;;    break, then compute where to go after a line-wrap:  If this is a
;;;    horizontal row, then start at the aggrelist.left+indentation; if this
;;;    is a vertical row, then start at the previously visible's :pre-align-left.
;;;
(defvar *pre-align-left-form*
  (o-formula
   (let* ((my-agg-list (gvl :parent)))
     ;; Now check if must wrap around
     (if (gvl :line-break-p)
	 (if (eq (gv my-agg-list :direction) :horizontal)
	     (gv my-agg-list :indent)
	     (+ (gvl :prev-visible :pre-align-left)
		(or (gv my-agg-list :fixed-width)
		    (gvl :prev-visible :col-width))
		(gv my-agg-list :h-spacing)))
	 (gvl :base-left)))))


;;; pre-align-top-form computes the value of the :pre-align-top slot in
;;;    each element of the list.  See PRE-ALIGN-LEFT-FORM for a description.
;;;
(defvar *pre-align-top-form*
  (o-formula
   (let* ((my-agg-list (gvl :parent)))
     ;; Now check if must wrap around
    (if (gvl :line-break-p)
	  (if (eq (gv my-agg-list :direction) :vertical)
			(gv my-agg-list :indent)
			(+ (gvl :prev-visible :pre-align-top)
			   (or (gv my-agg-list :fixed-height)
			       (gvl :prev-visible :row-height))
			   (gv my-agg-list :v-spacing)))
	  (gvl :base-top)))))


;;; compute the rank (index) of each component
;;;
(defvar *rank-form*
  (o-formula
   (let ((previous-rank (my-gv :self :prev :rank)))
     (if previous-rank (1+ previous-rank) 0))))


;;; prev-visible-form -- computes a link to the previously visible component
;;;
(defvar *prev-visible-form*
  (o-formula
   (let ((prev (gv-local :self :prev)))
     (if prev
	 (if (gv-local prev :visible)
	     prev
	     (gv-local prev :prev-visible))
	 NIL))))


;;; line-break-form computes :line-break-p
;;;   by seeing if the row or column would extend beyond the margin
;;;   established by :rank-margin or :pixel-margin
;;;
(defvar *line-break-form*
  (o-formula
   (let* ((rank (gvl :rank))
	  (my-agg-list  (gvl :parent))
	  rank-margin pixel-margin)
     ;; Now check if must wrap around
     (and (> rank 0)
	  (or (and (setf rank-margin (gv my-agg-list :rank-margin))
		   (eql (mod rank rank-margin) 0))
	      (and (setf pixel-margin (gv my-agg-list :pixel-margin))
		   (if (eq (gv my-agg-list :direction) :horizontal)
		       (> (+ (gvl :base-left) (gvl :width))
			  pixel-margin)
		       (> (+ (gvl :base-top) (gvl :height)) 
			  pixel-margin)
		       )))))))

(defvar *row-height-form*
  (o-formula (if (gvl :line-break-p)
		 (gvl :height)
		 (let ((prev (gvl :prev-visible)))
		   (if prev
		       (max (gvl :height)
			    (gv prev :row-height))
		       (gvl :height))))))
(defvar *col-width-form*
  (o-formula (if (gvl :line-break-p)
		 (gvl :width)
		 (let ((prev (gvl :prev-visible)))
		   (if prev
		       (max (gvl :width)
			    (gv prev :col-width))
		       (gvl :width))))))

;;; Compute the width and height of an aggrelist, without referencing the left
;;; or top of the aggrelist.  Note however that if the item objects are not of
;;; fixed width and height, their width and height will need to be calculated,
;;; which might (depending on their type) depend eventually on the left or top
;;; of the aggrelist.
;;;
(defun dimensions-fn ()
  (let ((currleft 0)
	(currtop 0)
	(width 0)
	(height 0)
	(h-spacing (gvl :h-spacing))
	(v-spacing (gvl :v-spacing))
	(indent (gvl :indent))
	(fixed-width (gvl :fixed-width))
	(fixed-height (gvl :fixed-height)))
    (if (eq (gvl :direction) :horizontal)
	(dolist (child (gvl :components))
	  (when (gv child :visible)
	    (cond ((gv child :line-break-p)
		   (setq currtop (+ height v-spacing))
		   (setq currleft indent)))
	    (setq currleft (+ currleft
			      (or fixed-width (gv child :width))
			      h-spacing))
	    (setq width (max width (- currleft h-spacing)))
	    (setq height (max height (+ currtop (or fixed-height
						    (gv child :height)))))))
	; for vertical aggrelists
	(dolist (child (gvl :components))
	  (when (gv child :visible)
	    (cond ((gv child :line-break-p)
		   (setq currtop indent)
		   (setq currleft (+ width h-spacing))))
	    (setq currtop (+ currtop
			     (or fixed-height (gv child :height))
			     v-spacing))
	    (setq width (max width
			     (+ currleft (or fixed-width (gv child :width)))))
	    (setq height (max height (- currtop v-spacing))))))
    (list width height)))


;;;--------------------------------------------------------------------------
;;;
;;;    Object definitions
;;;
;;;--------------------------------------------------------------------------

(create-instance 'null-object opal:view-object
	(:visible T))

(create-instance 'aggrelist opal:aggregate
 (:maybe-constant '(:left :top :width :height :direction :h-spacing :v-spacing
		    :indent :h-align :v-align :max-width :max-height
		    :fixed-width-p :fixed-height-p :fixed-width-size
		    :fixed-height-size :rank-margin :pixel-margin
		    :items :visible))
 (:left 0)
 (:top 0)
 (:direction :vertical)	;;; :horizontal or :vertical or NIL
 (:head nil)
 (:tail nil)
 (:h-spacing 5)		;;; Pixels between horizontal elements
 (:v-spacing 5)		;;; Pixels between vertical elements
 (:indent 0)		;;; How much to indent on wraparound
 (:h-align :left)	;;; Can be :left, :center, or :right
 (:v-align :top)	;;; Can be :top, :center, or :bottom
 ;; This new way to compute the :width and :height is buggy.
 (:dimensions (o-formula (dimensions-fn)))
 (:width (o-formula (first (gvl :dimensions))))
 (:height (o-formula (second (gvl :dimensions))))
 (:max-width  (o-formula (let ((width 0))
			   (dolist (c (gvl :components))
			      (when (gv c :visible)
				(setq width (max width (gv c :width)))))
			   width)))
 (:max-height (o-formula (let ((height 0))
			   (dolist (c (gvl :components))
			      (when (gv c :visible)
				(setq height (max height (gv c :height)))))
			   height)))
 (:fixed-width-p NIL)		;;; Width Fields of fixed-size?
 (:fixed-height-p NIL)		;;; Height Fields of fixed-size?
 (:fixed-width-size NIL)
 (:fixed-height-size NIL)
 (:rank-margin NIL)     ;;; If non-NIL, then after this many components, a
                        ;;; new row/column will be started for
                        ;;; horizontal/vertical lists
 (:items NIL)           ;;; List of the items (when itemized)
 (:item-prototype NIL)  ;;; Specification of prototype of the items
                        ;;; (when itemized)
 (:item-prototype-object NIL) ;;; the actual object
 (:base-left (formula *base-left-form*))
 (:base-top  (formula *base-top-form*))
 (:each-left (formula *each-left-form*))
 (:each-top  (formula *each-top-form*))
 (:fixed-width (o-formula (if (gvl :fixed-width-p)
			      (or (gvl :fixed-width-size)
				  (gvl :max-width)))))
 (:fixed-height (o-formula (if (gvl :fixed-height-p)
			       (or (gvl :fixed-height-size)
				   (gvl :max-height)))))
 )



;;;--------------------------------------------------------------------------
;;;
;;;    Methods for the aggrelist
;;;
;;;--------------------------------------------------------------------------


;;; Aggrelists and aggregadgets share some methods.  This function copies
;;; a method from aggregadget to aggrelist.  Since aggregadgets.lisp is loaded
;;; first, the aggregadget method is created and ready to be copied.
;;;
(defun share-aggregadget-method (slot)
  (s-value aggrelist slot
	 (let ((fn (get-local-value aggregadget slot)))
	   (unless fn (error "a method is missing from aggregadget"))
	   (s-value aggrelist slot fn)
	   fn)))

(share-aggregadget-method :add-local-interactor)

(share-aggregadget-method :remove-local-interactor)

;;; destroy-me -- gets interactors, item-prototype, as well as components
;;;
(define-method :destroy-me opal:aggrelist (agg &optional (top-level-p t))
  (dolist (behavior (copy-list (g-local-value agg :behaviors)))
    (destroy behavior))
  (call-prototype-method agg top-level-p))


;;;----------------------------------------------------------------------
;;;
;;;   Initialization method for aggrelists
;;;
;;;----------------------------------------------------------------------

;;; ITEMIZED AGGRELISTS: When all the components of an aggrelist are of a
;;; same type, they can be automatically created according to a prototype
;;; (specified in the :item-prototype slot, the actual instance is in the
;;; :item-prototype-object slot) and a list of items (given in the
;;; :items slot). Add-Local-Item and Remove-Local-Item allow to modify
;;; the items of an itemized aggrelist after it has been created.

(defun append-aggrelist-maintenance-formulas (agg slots)
  `((:rank ,(formula *rank-form*))
    (:prev-visible ,(formula *prev-visible-form*))
    ,@(if (g-value agg :direction)
	  `((:left ,(formula *each-left-form*))
	    (:top  ,(formula *each-top-form*))
	    (:base-left  ,(formula *base-left-form*))
	    (:base-top   ,(formula *base-top-form*))
	    (:row-height ,(formula *row-height-form*))
	    (:col-width  ,(formula *col-width-form*))
	    (:pre-align-left ,(formula *pre-align-left-form*))
	    (:pre-align-top  ,(formula *pre-align-top-form*))
	    (:line-break-p   ,(formula *line-break-form*))))
    ,@slots))


(defun Generate-Aggrelist-Components (agg item-prototype number-of-comps)
  ;; The :constant list of each component must be conditioned on
  ;; whether the :parent's :items slot is constant
  (if (kr::slot-constant-p agg :items)
      (let ((prev-component NIL))
	(dotimes (count number-of-comps)
	  (let* ((kr::*redefine-ok* T)
		 (kr::*constants-disabled* T)
		 (new-component (create-instance NIL item-prototype
				  (:parent agg)
				  (:internally-parented T)
				  (:prev prev-component))))
	    (cond (prev-component
		   (s-value agg :tail new-component)
		   (s-value prev-component :next new-component))
		  (t (s-value agg :head new-component)))
	    ;; Skip the aggrelist add-component method since we've
	    ;; already done all the aggrelist bookkeeping.
	    (kr-send opal:aggregate :add-component agg new-component)
	    (declare-constant new-component :parent)
	    (declare-constant new-component :prev)
	    (setf prev-component new-component)))
	(kr:declare-constant agg :head)
	(kr:declare-constant agg :tail)
	(kr:declare-constant agg :components))
      (let ((prev-component NIL))
	(dotimes (count number-of-comps)
	  (let ((new-component (create-instance NIL item-prototype
				 (:parent agg)
				 (:internally-parented T)
				 (:prev prev-component))))
	    (add-local-component agg new-component)
	    (setf prev-component new-component))))))

;;;
;;; Create-Items uses the value of :items if it's a number, or its
;;; cardinality if it's a list, to create that very number of instances
;;; of :item-prototype-object.  Each of these instances is added as a component
;;; of the aggrelist.
;;;
(defun create-items (agg)
  (let* ((item-prototype-description (g-local-value agg :item-prototype))
	 (item-prototype
	  (cond
	   ;; The :item-prototype slot is empty -- This aggrelist is an
	   ;; instance of a prototype aggrelist, so inherit the item-prototype
	   ((null item-prototype-description)
	    (g-value agg :item-prototype-object))
	   ;; The :item-prototype slot contains a description of an object --
	   ;; Create the item-prototype according to this description
	   ((listp item-prototype-description)
	    (let* ((car-of-desc (car item-prototype-description)))
	      (if (eq car-of-desc :modify)
		  ;; get prototype from agg's prototype
		  (call-create-instance (g-value agg :item-prototype-object)
					(cdr item-prototype-description)
					agg)
		  ;; the car is a prototype schema
		  (call-create-instance car-of-desc
					(append-aggrelist-maintenance-formulas
					 agg (cdr item-prototype-description))
	                                agg))))
	   ;; The :item-prototype slot contains a schema
	   (t (call-create-instance item-prototype-description
				    (append-aggrelist-maintenance-formulas
				     agg NIL)
		                    agg)))))

    ;; If there is an item-prototype, this is an itemized aggrelist
    (if item-prototype
	(let* ((source-value (g-value agg :items))
	       (number-of-comps (if (numberp source-value)
				    source-value
				    (length source-value))))
	  (s-value agg :number-of-comps number-of-comps)
	  (s-value agg :item-prototype-object item-prototype)
	  (Generate-Aggrelist-Components agg item-prototype number-of-comps)))))


(define-method :initialize aggrelist (my-agg-list)
  (call-prototype-method my-agg-list)
  (create-items my-agg-list)
  (let ((prototype (car (g-value my-agg-list :is-a)))
	(items-proto (g-local-value my-agg-list :item-prototype-object))
	(parts-list (g-local-value my-agg-list :parts))
	(inter-list (g-local-value my-agg-list :interactors)))
    (if (not items-proto)
	;; After making parts from the :parts list, go through each component
	;; and mark the :prev slot constant (:prev was set during the
	;; add-local-component of aggrelists).
	(when parts-list
	  (make-parts my-agg-list parts-list prototype)
	  (declare-constant my-agg-list :components)
	  (declare-constant my-agg-list :head)
	  (declare-constant my-agg-list :tail)
	  (dolist (part (g-value my-agg-list :components))
	    (declare-constant part :parent)
	    (declare-constant part :prev))))
    (if (or (null inter-list)
	    (not (is-first-comp-in-parts-list
		  (g-value prototype :behaviors) inter-list)))
	(make-inters-from my-agg-list prototype))
    (make-interactors my-agg-list inter-list prototype)))

;; This code installs the aggrelist maintenance formulas in a new component
;; of the aggrelist.  It used to be called from the :add-local-component
;; method, but now these formulas are installed in the component at
;; create-instance time.
(defun install-aggrelist-component-formulas (obj agg)
  (dolist (pair (append-aggrelist-maintenance-formulas agg NIL))
    (s-value obj (first pair) (second pair))))


;;;--------------------------------------------------------------------------
;;;
;;;    Add-Component and Remove-Component methods for aggrelists
;;;
;;;--------------------------------------------------------------------------

;;; This function is used to analyze the &rest part of the parameters to
;;; add-local-item methods.  It returns three (multiple) values.
;;;
(defun Get-Wheres (args)
  (let (where locator key)
    (cond ((eq (first args) :where)
	   (setq where (second args))
	   (case where
	     ((:front :back :head :tail)
	      (setq locator NIL)
	      (setq key (if (eq (third args) :key)
			    (fourth args)
			    #'opal:no-func)))
	     (t (setq locator (third args))
		(setq key (if (eq (fourth args) :key)
			      (fifth args)
			      #'opal:no-func)))))
	  ((first args)
	   (setq where (first args))
	   (case where
	     ((:font :back :head :tail)
	      (setq locator NIL)
	      (setq key (if (eq (second args) :key)
			    (third args)
			    #'opal:no-func)))
	     (t (setq locator (second args))
		(setq key (if (eq (third args) :key)
			      (fourth args)
			      #'opal:no-func)))))
	  (t (setq where :front)
	     (setq locator NIL)
	     (setq key #'no-func)))
    (values where locator key)))


;; Supports Add-Component's terminology (screen related):
;;	:front :back :behind :in-front :at
;; And also the corresponding names (list related):
;;      :tail  :head :before :after    :at
;;
;; Also, you can call it as (add-element list-agg element :where :head)
;; or you can simply omit the ':where' field (again, to be like Add-Component)
;;
;; The default is for :where is :tail
;;
;; The big inefficiency right now is that after it finds the element in
;; the :components slot, it eventually calls "call-prototype-method", which
;; will do the same thing all over again!

; element - the new component to be added
; elements - the old components of the aggregate
;
(define-method :add-local-component aggrelist (my-agg-list element &rest args)
 (let ((elements (g-local-value my-agg-list :components)) 
       where locator
       (name (g-local-value element :known-as)))
   (when (member element elements)
     (remove-local-component my-agg-list element))

   ;; If the new component was generated by the aggrelist initialization
   ;; method, then it already has the necessary maintenance formulas
   ;; (inherited from the item-prototype).  Otherwise, it is a user-created
   ;; object that needs to be set with the aggrelist maintenance formulas.
   (if (not (formula-p (get-value element :rank)))
       (let ((kr::*constants-disabled* T))
	 (install-aggrelist-component-formulas element my-agg-list)))
   
   ; If the component is named, then set a slot in the aggregate so that it
   ; can be accessed through that slot
   (if name (s-value my-agg-list name element))

   (multiple-value-setq (where locator) (get-wheres args))

   ;Call Add-Component
   (do ((successful nil successful))	;;; This is better done with a GO
       (successful t)
     (setq successful t)                ;;; So we must set to NIL for repeat
     (setq elements (g-local-value my-agg-list :components))
     (cond ((null (g-local-value my-agg-list :tail))	;;;; NEW LIST ???
	    (s-value element :prev nil)
	    (s-value element :next nil)
	    (s-value my-agg-list :tail element)
	    (s-value my-agg-list :head element)
	    (kr-send aggregate :add-component my-agg-list element))
	   ((or (eq where :front)
		(eq where :tail))
	    (let ((old-tail (g-local-value my-agg-list :tail)))
	      (s-value old-tail :next element)
	      (s-value element :next nil)
	      (s-value element :prev old-tail)
	      (s-value my-agg-list :tail element)
	      (kr-send aggregate :add-component 
		       my-agg-list element :where :front)))
	   ((or (eq where :back)
		(eq where :head))
	    (let ((old-head (g-local-value my-agg-list :head)))
	      (s-value old-head :prev element)
	      (s-value element :prev nil)
	      (s-value element :next old-head)
	      (s-value my-agg-list :head element)
	      (kr-send aggregate :add-component 
		       my-agg-list element :where :back)))
	   ((or (eq where :behind)		;;; Goes after 'behind-element'
		(eq where :before))
	    (let ((mem-sublist (member locator elements)))
	      (if mem-sublist
		  (let ((behind-element (g-value locator :prev)))
		    (setq mem-sublist (cdr mem-sublist))
		    (s-value element :prev behind-element)
		    (s-value element :next locator )
		    (s-value locator :prev element)
		    (if behind-element
			(s-value behind-element :next element)
			(s-value my-agg-list :head element))
		    (kr-send aggregate :add-component 
			     my-agg-list element :where :behind locator))
		  (progn
		    (warn "New element being placed at back of aggrelist.")
		    (setq where :back)		;;; Just put it at the back
		    (setq successful nil)))))	;;; by looping again
	   ((eq where :at)
	    (let ((count (length elements)))
	      (setq locator (max (num-or-zero locator) 0))
	      (setq locator (min locator count))
	      (cond ((eq locator 0) (setq where :back))
		    ((eq locator count) (setq where :front))
		    (t (setq locator (nth locator elements))
		       (setq where :before)))
	      (setq successful nil)))	;;; by looping again
	   ((or (eq where :in-front)	;;; Search list backwards!
		(eq where :after))
	    (let ((mem-sublist (member locator elements)))
	      (if mem-sublist
		  (let ((infront-element (g-value locator :next)))
		    (s-value element :prev locator)
		    (s-value element :next infront-element )
		    (s-value locator :next element)
		    (if infront-element
			(s-value infront-element :prev element)
			(s-value my-agg-list :tail element))
		    (kr-send aggregate :add-component
			     my-agg-list element :where :in-front locator))
		  (progn
		    (warn "New element being placed at front of aggrelist.")
		    (setq where :front)		;;; Just put it at the front
		    (setq successful nil)))))	;;; by looping again
	   (t (format t "***Illegal :where ('~S') in 'list-add'~%" where)
	      (format t "***  Defaulting, settting :where to :front~%")
	      (setq where :front)
	      (setq successful nil))))
   ))

(define-method :remove-local-component aggrelist (my-agg-list element)
  (let ((next (g-value element :next))
	(prev (g-value element :prev))
	(name (g-local-value element :known-as)))
    (cond (name
	   (destroy-slot my-agg-list name)))
    (when (eq element (g-value my-agg-list :tail))
      (s-value my-agg-list :tail prev))
    (when (eq element (g-value my-agg-list :head))
      (s-value my-agg-list :head next))
    (if prev (s-value prev :next next))
    (if next (s-value next :prev prev))
    (destroy-constraints element :prev :next :rank :prev-visible)
    (when (g-value my-agg-list :direction)
      (destroy-constraints element :left :top :base-left :base-top
			   :pre-align-left :pre-align-top))
    (kr-send aggregate :remove-component my-agg-list element)
    ))


;;;--------------------------------------------------------------------------
;;;
;;;    Add-Item and Remove-Item methods
;;;
;;;--------------------------------------------------------------------------

;;; This function returns the items list with the new item inserted in the
;;; proper place
;;;
(defun Insert-Item (item items where locator key)
  (cond ((null item)  ;; No specific item supplied -> just add an instance
	              ;; of :prototype-item in the components
	 (if (numberp items)
	     (1+ items)
	     (add-last nil items)))
	((or (eq where :front) (eq where :tail))
	 (add-last item items))
	((or (eq where :back) (eq where :head))
	 (push item items))
	((or (eq where :behind) (eq where :before))
	 (add-before item locator items key))
	((eq where :at)
	 (add-at item locator items))
	((or (eq where :in-front) (eq where :after))
	 (add-after item locator items key))
	(t (warn "***Illegal :where ('~S') ~%" where)
	   (warn "***  Defaulting, setting :where to :front~%") 
	   (add-last item items))))


;;; remove-nth -- remove the nth element of a list destructively
;;;
;;; find the nthcdr before the element and splice out the nth element
;;;
(defun remove-nth (n l)
  (cond ((= n 0) 
	 (cdr l))
	(t
	 (let ((c (nthcdr (1- n) l)))
	   (cond ((cdr c)
		  (setf (cdr c) (cddr c))))
	   l))))


(define-method :remove-nth-component aggrelist (agg n)
  (let ((target (nth n (g-local-value agg :components))))
    (cond (target
	   (remove-local-component agg target)))))


;;; Adds elt at the end of list.
(defun add-last (elt list)
  (nreverse (cons elt (reverse list))))

;;; Adds elt at the index position of list.
(defun add-at (elt index list)
  (let ((new-list NIL) (cptr 0))
    (dolist (current-elt list)
      (when (eq cptr index)
	(push elt new-list))
      (push current-elt new-list)
      (incf cptr))
    (when (>= index cptr)
      (push elt new-list))
    (nreverse new-list)))

;;; Adds elt before here in list, using key to do the matching.
(defun add-before (elt here list key)
  (let ((new-list NIL) (found NIL))
    (dolist (current-elt list)
      (if (and (null found)
	       (or (equal here (funcall key current-elt))
		   (and (listp here) (equal (funcall key here)
					    (funcall key current-elt)))))
	  (progn
	    (push elt new-list)
	    (push current-elt new-list)
	    (setf found T))
	  (push current-elt new-list)))
    (if (null found)
	(setf new-list (cons elt (nreverse new-list)))
	(setf new-list (nreverse new-list)))
    new-list))

;;; Adds elt after here in list, using key to do the matching.
(defun add-after (elt here list key)
  (let ((new-list NIL) (found NIL))
    (dolist (current-elt list)
      (if (and (null found)
	       (or (equal here (funcall key current-elt))
		   (and (listp here) (equal (funcall key here)
					    (funcall key current-elt)))))
	  (progn
	    (push current-elt new-list)
	    (push elt new-list)
	    (setf found T))
	  (push current-elt new-list)))
    (when (null found)
      (push elt new-list))
    (nreverse new-list)))

;;; Removes elt from list, using key to do the matching.
(defun delete-elt (elt list key)
  (let ((new-list NIL) (found NIL))
    (dolist (current-elt list)
      (if (and (null found)
	       (or (equal elt (funcall key current-elt))
		   (and (listp elt) (equal (funcall key elt)
					   (funcall key current-elt)))))
	  (setf found T)
	  (push current-elt new-list)))
    (nreverse new-list)))



