;;; -*- 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. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Copy an aggregadget.
;;; 
;;; Roger B. Dannenberg, 1990

#|
======================================================================
Change log:
06/22/92 Andrew Mickish - Added parameter to kr::process-constant-slots
04/09/92 Dario Guise    - Changed "ordinary copy" clause of Copy-Slots
                          for compatibility with new version of KR
04/01/92 Andrew Mickish - Added parameter to kr::process-constant-slots
03/03/92 Andrew Mickish - Called Get-Inherited-Value instead of Inherit-Value
02/19/92 Dario Giuse    - Modified COPY-SLOTS to keep constant bits from the
			  source schema.  This means that COPY-GADGET preserves
			  constant information.
02/14/92 Dario Giuse    - Removed obsolete check for :DEPENDED-SLOTS.
			  Added some more kr::*constants-disabled* in
			  COPY-SLOTS.
02/14/92 Andrew Mickish - Bound kr::*constants-disabled* in COPY-SLOTS
02/04/92 Andrew Mickish - Added kr::process-constant-slots and new-parent
           parameter to COPY-SLOTS.
01/07/92 Andrew Mickish - Added progn in COPY-SLOTS to set variables properly
12/09/91 Andrew Mickish - Converted from multiple- to single-valued slots
01/17/91 Dario Giuse    - Added a condition to the COND in COPY-SLOTS
======================================================================
|#

#| Implementation details:

Copy works much like saving, except rather than writing out the structure,
a duplicate structure is built.  The copy operation does not create
instances because an instance of an aggregadget's parent would create parts
that might not match the parts of the aggregate.  
|#

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

(defun copy-gadget (agget name &optional new-parent)
  (let* ((copy (if name (create-schema name) (create-schema nil)))
	 (known-as (g-value agget :known-as))
	 (parent (g-value agget :parent))
	 (parent-proto (if parent (car (g-local-value parent :is-a))))
	 (normal-proto (if (and known-as parent-proto)
			   (g-local-value parent-proto known-as)))
	 (components (g-local-value agget :components))
	 (behaviors (g-local-value agget :behaviors)))
    (copy-slots copy agget normal-proto components behaviors new-parent)
    copy))


(defun copy-slots (copy agget normal-proto components behaviors new-parent)
  (let ((proto (car (g-local-value agget :is-a)))
	;; dzg - use this call, which does not actually inherit the slot.
	(standard-slots (kr::g-value-no-copy agget :DO-NOT-DUMP-SLOTS))
	value values item-prototype-object)

    ;; set the IS-A slot
    (let ((kr::*demons-disabled* t)
	  (kr::*schema-is-new* t))
      (s-value copy :is-a (list proto)))

    (doslots (slot agget)
      ;; don't copy automatically generated slots
      (cond ((eq slot :known-as)
	     ;; copy :known-as even if it is a standard slot
	     (let ((value (g-value agget :known-as))
		   (kr::*constants-disabled* T))
	       (s-value copy :known-as value)))

	    ;; there are certain slots we don't want to copy		   
	    ((member slot standard-slots))

	    ;; don't copy parts or behaviors (yet)
	    ((progn
	       (setf values (get-local-value agget slot))
	       (setf value (if (consp values) (car values) values))
	       (and values value (schema-p value)
		    (or (member value components)
			(member value behaviors))))
	     (if (not (eq slot (g-value value :known-as)))
	       (format *error-output*
		       "Warning: slot ~S of ~S: ~S not copied.~%"
		       slot agget value)))

	    ;; don't copy inherited formulas:
	    ((slot-has-an-inherited-formula slot value proto))

	    ;; test to see if this is an :inherit formula:
	    ((is-an-inherit-formula slot value normal-proto)
	     (let ((kr::*constants-disabled* T))
	       (s-value copy slot (get-inherited-value normal-proto slot))))

	    ;; special copy for formulas
	    ((formula-p value)
	     (let ((kr::*constants-disabled* T))
	       (s-value copy slot (kr::copy-formula value))))

	    ;; ordinary copy of anything that's left:
	    (t
	     ;; rather than doing a full copy-tree of the value,
	     ;;  just copy the top-most list and, if the first
	     ;;  element is a list, copy that one too
	     (if (consp values)
	       (setf values (copy-list values)))
	     (if (consp value)		; recall that value is (car values)
	       (setf (car values) (copy-list value)))
	     (let ((kr::*constants-disabled* T))
	       ;; Maintain constant bit information, if present.
	       (multiple-value-bind (value position)
		   (kr::slot-accessor agget slot)
		 (declare (ignore value))
		 (if (kr::is-constant (kr::last-slot-bits
				       (kr::schema-slots agget)
				       position))
		     (kr::set-slot-accessor copy slot values kr::*constant-mask*)
		     (s-value copy slot values)))))))
    (if new-parent
      (let ((kr::*constants-disabled* T))
	(s-value copy :parent new-parent)
	(s-value copy :internally-parented T)))
    (kr::process-constant-slots copy (list proto)
				(g-local-value proto :constant)
				(g-local-value proto :link-constant))

    (if (or (is-a-p copy aggregadget) (is-a-p copy aggrelist))
      ;; start at aggregate level to avoid copying
      ;;  components (which is what initialize-method-aggregadget does).
      (kr-send aggregate :initialize copy)
      (kr-send copy :initialize copy))

    ;; if this is an itemized aggrelist, set up :number-of-comps
    (setf item-prototype-object (g-local-value agget :item-prototype-object))
    (when item-prototype-object
      (s-value copy :item-prototype-object (copy-gadget 
					    item-prototype-object nil))
      (s-value copy :number-of-comps (length components)))

    (dolist (comp components)
      (let* ((comp-copy (copy-gadget comp nil copy))
	     (known-as (g-value comp-copy :known-as)))
	(if known-as
	  (let ((kr::*constants-disabled* T))
	    (s-value copy known-as comp-copy)))
	(add-local-component copy comp-copy)))

    (s-value copy :behaviors
	     (mapcar #'(lambda (inter)
			 (let ((inter-copy (copy-gadget inter nil)))
			   (s-value inter-copy :operates-on copy)
			   inter-copy))
		     behaviors))))



