;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: XIT
;;;                       Module: copy windows
;;;                       Version: 1.0
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Juergen Herczeg
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/kernel/copy-windows.lisp
;;; File Creation Date: 03/19/92 13:58:02
;;; Last Modification Time: 10/02/92 09:28:26
;;; Last Modification By: Juergen Herczeg
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;;_____________________________________________________________________________

(in-package :xit)

(defmethod copy-and-move-window ((self basic-contact))
  (declare (special *copy*))
  (let ((new-window (while-busy () (copy self))))
    (setq *copy* new-window)
    (with-slots (display parent) new-window
      (update-state display)
      (process-all-events display)
      (unless (and (layouted-p new-window)
		   (typep parent 'layouted-window)
		   (layouter parent))
	(move-window new-window)))
    new-window))

(defmethod copy-window-to-parent ((self basic-contact) (new-parent composite))
  (declare (special *copy*))
  (with-slots (display) self
    (let ((new-window (while-busy () (copy self))))
      (setq *copy* new-window)
      (update-state display)
      (when new-parent 
	(setf (contact-parent new-window) new-parent))
      (process-all-events display)
      (unless (and (layouted-p new-window)
		   (typep new-parent 'layouted-window)
		   (layouter new-parent))
	(move-window new-window))
      new-window)))

(defmethod uninitialized-copy ((object pixmap) &key &allow-other-keys)
  ;; pixmaps are not copied
  object)

(defmethod uninitialized-copy ((object image) &key &allow-other-keys)
  ;; images are not copied
  object)

(defmethod uninitialized-copy ((object font) &key &allow-other-keys)
  ;; fonts are not copied
  object)

(defmethod uninitialized-copy ((object display) &key &allow-other-keys)
  ;; displays are not copied
  object)

(defmethod ut::after-initialization :before ((old-object basic-contact)
					     (new-object basic-contact))
  (setf (slot-value new-object 'xlib::id) 0))

(defmethod ut::after-initialization :after ((old-object basic-contact)
					    (new-object basic-contact))
  (with-slots (display parent) new-object
    (let* ((old-parent (slot-value old-object 'parent))
	   (parent-copy (ut::get-copy old-parent)))
      (setf parent (or parent-copy old-parent))
      (unless parent-copy (cluei::add-to-parent new-object)))
    (setf (cluei::display-update-flag display) t)))

(defmethod ut::slots-for-copy :around ((object basic-contact))
  (delete-all '(xlib::id parent)
	      (call-next-method)))

(defmethod ut::slots-for-copy :around ((object composite))
  (delete-all '(focus children)
	      (call-next-method)))

(defmethod ut::slots-for-deep-copy :around ((object composite))
  (append (call-next-method)
	  '(children)))

(defmethod ut::after-initialization :after ((old-object composite)
					    (new-object composite))
  (with-slots (focus) old-object
    (setf (slot-value new-object 'focus)
	(if (eq focus old-object)
	    new-object
	  focus))))

#||
(defmethod ut::slots-for-identity :around ((object basic-contact))
  (append (call-next-method)
	  '(parent)))

(defmethod ut::after-initialization :after ((old-object basic-contact)
					    (new-object basic-contact))
  (when (slot-boundp new-object 'parent)
    (cluei::add-to-parent new-object))
  (setf (cluei::display-update-flag (contact-display new-object)) t))

(defmethod ut::slots-for-copy :around ((object composite))
  (delete-all '(focus children)
	      (call-next-method)))
	 
(defmethod ut::before-initialization :after ((old-object composite)
					    (new-object composite))
  (setf (slot-value new-object 'children) nil))	

(defmethod ut::after-initialization :after ((old-object composite)
					    (new-object composite))
  (with-slots (focus children) old-object
    (setf (slot-value new-object 'focus)
	(if (eq focus old-object)
	    new-object
	  focus))
    (setf (slot-value new-object 'children)
	(mapcar
	 #'(lambda (child)
	     (let ((new-child
		    (copy child :discard-slots '(parent))))
	       (setf (slot-value new-child 'parent) new-object)
	       new-child))
	 children))))
||#

(defmethod ut::slots-for-copy :around ((object view))
  (delete 'view-of (call-next-method)))

(defmethod ut::slots-for-identity :around ((object view))
  (append (call-next-method) '(view-of)))

#||
(defmethod ut::after-initialization :after ((old-object layouted-window)
					    (new-object layouted-window))
  (with-slots (layouter) new-object
    (when layouter
      (setf (slot-value layouter 'window)
	  new-object))))

(defmethod ut::slots-for-copy :around ((object layouter))
  (delete 'window (call-next-method)))
||#

(defmethod ut::after-initialization :after ((old-object window-icon-mixin)
					    (new-object window-icon-mixin))
  (with-slots (window-icon) new-object
    (when (typep window-icon 'view)
      (setf (view-of window-icon) new-object))))

(defmethod ut::slots-for-copy :around ((object focus-mixin))
  (delete 'keyboard-focus (call-next-method)))
	 
(defmethod ut::after-initialization :after ((old-object focus-mixin)
					    (new-object focus-mixin))
  (with-slots (keyboard-focus) old-object
    (setf (slot-value new-object 'keyboard-focus)
	(if (eq keyboard-focus old-object)
	    new-object
	  keyboard-focus))))

#||
(defmethod ut::slots-for-copy :around ((object shadow-borders-mixin))
  (delete 'shadow (call-next-method)))

(defmethod ut::after-initialization :after ((old-object shadow-borders-mixin)
					    (new-object shadow-borders-mixin))
  (with-slots (shadow) new-object
    ;(when shadow
      ;(setf (slot-value shadow 'shadow-of)
	  ;new-object))
    (setf shadow nil)))

(defmethod ut::slots-for-copy :around ((object shadow-border))
  (delete 'shadow-of (call-next-method)))

(defmethod ut::after-initialization :after ((old-object shadow-border)
					    (new-object shadow-border))
  (with-slots (shadow-of) new-object
    (setf shadow-of nil)))
||#
	 
(defmethod ut::after-initialization :after ((old-object view-mixin)
					    (new-object view-mixin))
  (with-slots (view) new-object
    (when view
      (setf (slot-value view 'view-of)
	  new-object))))

