anchor.diff:  ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
   
  -;;;  (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com)
  +;;;  (c) copyright 1998,1999,2000 by 
  +;;;  Michael McDonald (mikemac@mikemac.com), 
  +;;;  Robert Strandh (strandh@labri.u-bordeaux.fr), 
  +;;;  Iban Hatchondo (hatchond@emi.u-bordeaux.fr),
  +;;;  Julien Boninfante (boninfan@emi.u-bordeaux.fr).
   
   ;;; This library is free software; you can redistribute it and/or
   ;;; modify it under the terms of the GNU Library General Public
  
positive.code:   (remove sheet (sheet-children (sheet-parent sheet))))
  
  (defmethod sheet-enabled-children ((sheet sheet))
    (loop for child in (sheet-children sheet)
         if (sheet-enabled-p child)
  	  collect child))
  
  (defmethod sheet-ancestor-p ((sheet sheet) (putative-ancestor sheet))
    (loop for s = (sheet-parent sheet) then (sheet-parent s)
         until (null s)
         if (eq s putative-ancestor)
  	  return t
         finally (return nil)))
  
  (defmethod raise-sheet ((sheet sheet))
    (with-slots (children) (sheet-parent sheet)
      (setf children (cons sheet (remove sheet children))))
    sheet)
  
  (defmethod bury-sheet ((sheet sheet))
    (with-slots (children) (sheet-parent sheet)
      (setf children (nconc (remove sheet children) (list sheet))))
    sheet)
  
  (define-condition sheet-ordering-underspecified (error)
    (
     ))
  
  (defmethod reorder-sheets ((sheet sheet) new-ordering)
    (with-slots (children) sheet
      (if (set-difference children new-ordering)
  	(error 'sheet-ordering-underspecified))
      (if (set-difference new-ordering children)
  	(error 'sheet-is-not-child))
      (setf children new-ordering))
    sheet)
  
  (defmethod sheet-viewable-p ((sheet sheet))
    (and (sheet-enabled-p sheet)
         (or (null (sheet-parent sheet))
  	   (sheet-viewable-p (sheet-parent sheet)))))
  
  (defmethod sheet-occluding-sheets ((sheet sheet) (child sheet))
    (let ((childs-region (sheet-region child))
  	(results nil))
      (do ((children (sheet-children sheet) (cdr children)))
  	((or (null children)
  	     (eq (first children) child)))
        (if (and (sheet-enabled-p (first children))
  	       (region-intersects-region-p childs-region (sheet-region (first children))))
  	  (push (first children) results)))
      results))
  
  ;;; SHEET mixin classes
  
  (defclass sheet-parent-mixin ()
    ((parent :initform nil
  	   :reader sheet-parent)
     ))
  
  (defmethod set-sheets-parent ((child sheet-parent-mixin) (parent sheet))
    (setf (slot-value child 'parent) parent))
  
  (defclass sheet-leaf-mixin ()
    (
     ))
  
  (defmethod sheet-adopt-child ((sheet sheet-leaf-mixin) (child sheet))
    (error "Leaf sheet attempting to adopt a child"))
  
  (defclass sheet-single-child-mixin ()
    ((children :initform nil
  	     :reader sheet-children)
     ))
  
  (defmethod sheet-adopt-child ((sheet sheet-single-child-mixin) (child sheet))
    (if (sheet-parent child)
        (error 'sheet-already-has-parent))
    (if (sheet-children sheet)
        (error "Single Child Sheet attempting to adopt a second child"))
    (set-sheets-parent child sheet)
    (with-slots (children) sheet
      (setf children (list child)))
    child)
  
  (defclass sheet-multiple-child-mixin ()
    ((children :initform nil
  	     :reader sheet-children)
     ))
  
  (defmethod sheet-adopt-child ((sheet sheet-multiple-child-mixin) (child sheet))
    (if (sheet-parent child)
        (error 'sheet-already-has-parent))
    (set-sheets-parent child sheet)
    (with-slots (children) sheet
      (setf children (append children (list child))))
    child)
  
  ;;; SHEET geometry functions
  
  (defmethod map-sheet-position-to-parent ((sheet sheet) x y)
    (transform-position (sheet-transformation sheet) x y))
  
  (defmethod map-sheet-position-to-child ((sheet sheet) x y)
    (transform-position (invert-transformation (sheet-transformation sheet)) x y))
  
  (defmethod map-sheet-rectangle*-to-parent ((sheet sheet) x1 y1 x2 y2)
    (transform-rectangle* (sheet-transformation sheet) x1 y1 x2 y2))
  
  (defmethod map-sheet-rectangle*-to-child ((sheet sheet) x1 y1 x2 y2)
    (transform-rectangle* (invert-transformation (sheet-transformation sheet)) x1 y1 x2 y2))
  
  (defmethod child-containing-position ((sheet sheet) x y)
    (loop for child in (sheet-children sheet)
        do (multiple-value-bind (tx ty) (map-sheet-position-to-child child x y)
  	   (if (and (sheet-enabled-p child)
  		    (region-contains-position-p (sheet-region child) tx ty))
  	       (return child)))))
  
  (defmethod children-overlapping-region ((sheet sheet) (region region))
    (loop for child in (sheet-children sheet)
        if (and (sheet-enabled-p child)
  	      (region-intersects-region-p region (transform-region (sheet-transformation child) (sheet-region child))))
        collect child))
  
  (defmethod children-overlapping-rectangle* ((sheet sheet) x1 y1 x2 y2)
    (loop with region = (make-rectangle* x1 y1 x2 y2)
        for child in (sheet-children sheet)
        if (and (sheet-enabled-p child)
  	      (region-intersects-region-p region (transform-region (sheet-transformation child) (sheet-region child))))
        collect child))
  
  (defmethod sheet-delta-transformation ((sheet sheet) (ancestor (eql nil)))
    (if (sheet-parent sheet)
        (compose-transformations (sheet-transformation sheet)
  			       (sheet-delta-transformation
  				(sheet-parent sheet) ancestor))
        (sheet-transformation sheet)))
    
  (define-condition sheet-is-not-ancestor (error) ())
  
  
negative.code: 	(t (error 'sheet-is-not-ancestor))))
  
  (defmethod sheet-allocated-region ((sheet sheet) (child sheet))
    (reduce #'region-difference
  	  (mapc #'(lambda (child)
  		    (transform-region (sheet-transformation child)
  				      (sheet-region child)))
  		(cons child (sheet-occluding-sheets sheet child)))))
  
  (defmethod sheet-direct-mirror ((sheet sheet))
    nil)
  
  (defmethod sheet-mirrored-ancestor ((sheet sheet))
    (if (sheet-parent sheet)
        (sheet-mirrored-ancestor (sheet-parent sheet))))
  
  (defmethod sheet-mirror ((sheet sheet))
    (let ((mirrored-ancestor (sheet-mirrored-ancestor sheet)))
      (if mirrored-ancestor
  	(sheet-direct-mirror mirrored-ancestor))))
  
  (defmethod graft ((sheet sheet))
    nil)
  
  (defmethod graft ((sheet null))
    (values))
  
  (defmethod note-sheet-grafted ((sheet sheet))
    nil)
  
  (defmethod note-sheet-degrafted ((sheet sheet))
    nil)
  
  (defmethod note-sheet-adopted ((sheet sheet))
    (when (sheet-grafted-p sheet)
      (note-sheet-grafted sheet)))
  
  (defmethod note-sheet-disowned ((sheet sheet))
  ;  (when (sheet-grafted-p sheet)
    (note-sheet-degrafted sheet))
  
  (defmethod note-sheet-region-changed ((sheet sheet))
    nil) ;have to change
  
  (defmethod note-sheet-transformation-changed ((sheet sheet))
    nil)
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; sheet parent mixin
  
  
  (defclass sheet-parent-mixin ()
    ((parent :initform nil :accessor sheet-parent)))
  
  
  (defmethod set-sheets-parent ((child sheet-parent-mixin) (parent sheet))
    (setf (slot-value child 'parent) parent))
  
  (define-condition sheet-already-has-parent (error) ())
  (define-condition sheet-is-ancestor (error) ())
  
  (defmethod sheet-adopt-child :before (sheet (child sheet-parent-mixin))
    (when (sheet-parent child) (error 'sheet-already-has-parent))
    (when (sheet-ancestor-p sheet child) (error 'sheet-is-ancestor)))
  
  (defmethod sheet-adopt-child :after (sheet (child sheet-parent-mixin))
    (setf (sheet-parent child) sheet))
  
  (defmethod sheet-disown-child :before (sheet
  				       (child sheet-parent-mixin)
  				       &key (errorp t))
    (when (and errorp (not (eq sheet (sheet-parent child))))
      (error 'sheet-is-not-child)))
  
  (defmethod sheet-disown-child :after (sheet
  				      (child sheet-parent-mixin)
  				      &key (errorp t))
    (declare (ignorable errorp))
    (setf (sheet-parent child) nil))
  
  (defmethod sheet-siblings ((sheet sheet-parent-mixin))
    (when (not (sheet-parent sheet))
      (error 'sheet-is-not-child))
    (remove sheet (sheet-children (sheet-parent sheet))))
  
  (defmethod sheet-ancestor-p ((sheet sheet-parent-mixin)
  			     (putative-ancestor sheet))
    (or (eq sheet putative-ancestor)
        (and (sheet-parent sheet)
  	   (sheet-ancestor-p (sheet-parent sheet) putative-ancestor))))
  
  (defmethod raise-sheet ((sheet sheet-parent-mixin))
    (when (not (sheet-parent sheet))
      (error 'sheet-is-not-child))
    (raise-sheet-internal sheet (sheet-parent sheet)))
  
  (defmethod bury-sheet ((sheet sheet-parent-mixin))
    (when (not (sheet-parent sheet))
      (error 'sheet-is-not-child))
    (bury-sheet-internal sheet (sheet-parent sheet)))
  
  (defmethod graft ((sheet sheet-parent-mixin))
    (graft (sheet-parent sheet)))
  
  (defmethod (setf sheet-transformation) :after (newvalue (sheet sheet-parent-mixin))
    (declare (ignore newvalue))
    (note-sheet-transformation-changed sheet))
  
  (defmethod map-sheet-position-to-parent ((sheet sheet-parent-mixin) x y)
    (transform-position (sheet-transformation sheet) x y))
  
  (defmethod map-sheet-position-to-child ((sheet sheet-parent-mixin) x y)
    (transform-position (invert-transformation (sheet-transformation sheet)) x y))
  
  (defmethod map-sheet-rectangle*-to-parent ((sheet sheet-parent-mixin) x1 y1 x2 y2)
    (transform-rectangle* (sheet-transformation sheet) x1 y1 x2 y2))
  
  (defmethod map-sheet-rectangle*-to-child ((sheet sheet-parent-mixin) x1 y1 x2 y2)
    (transform-rectangle* (invert-transformation (sheet-transformation sheet)) x1 y1 x2 y2))
  
  (defmethod raise-sheet ((sheet sheet-parent-mixin))
    (when (not (sheet-parent sheet))
      (error 'sheet-is-not-child))
    (raise-sheet-internal sheet (sheet-parent sheet)))
  
  (defmethod bury-sheet ((sheet sheet-parent-mixin))
    (when (not (sheet-parent sheet))
      (error 'sheet-is-not-child))
    (bury-sheet-internal sheet (sheet-parent sheet)))
  
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; sheet leaf mixin
  
  (defclass sheet-leaf-mixin () ())
  
  (defmethod sheet-children ((sheet sheet-leaf-mixin))
    nil)
  
  (defmethod sheet-adopt-child ((sheet sheet-leaf-mixin) (child sheet))
    (error "Leaf sheet attempting to adopt a child"))
  
  (defmethod sheet-disown-child ((sheet sheet-leaf-mixin) (child sheet) &key (errorp t))
    (declare (ignorable errorp))
    (error "Leaf sheet attempting to disown a child"))
  
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; sheet single child mixin
  
  (defclass sheet-single-child-mixin ()
    ((children :initform nil :initarg :child :accessor sheet-children)))
  
  (define-condition sheet-supports-only-one-child (error) ())
  
  (define-condition sheet-already-has-parent (error) ())
  
  (defmethod sheet-adopt-child :before ((sheet sheet-single-child-mixin)
  				      child)
    (declare (ignorable child))
    (when (sheet-children sheet) (error 'sheet-supports-only-one-child))
    (when (sheet-parent child) (error 'sheet-already-has-parent)))
  
  (defmethod sheet-adopt-child ((sheet sheet-single-child-mixin)
  			      (child sheet-parent-mixin))
    (setf (sheet-children sheet) child))
  
  (defmethod sheet-adopt-child :after ((sheet sheet-single-child-mixin)
  				     (child sheet-parent-mixin))
    (declare (ignorable sheet))
    (note-sheet-adopted child))
  
  (defmethod sheet-disown-child ((sheet sheet-single-child-mixin)
  			       (child sheet-parent-mixin)
  			       &key (errorp t))
    (declare (ignorable errorp))
    (setf (sheet-children sheet) nil))
  
  (defmethod sheet-disown-child :after ((sheet sheet-single-child-mixin)
  				      (child sheet-parent-mixin)
  				      &key (errorp t))
    (declare (ignorable sheet errorp))
    (note-sheet-disowned child))
  
  (defmethod reorder-sheets ((sheet sheet-single-child-mixin) new-order)
    (declare (ignorable sheet new-order))
    nil)
  
  (defmethod raise-sheet-internal (sheet (parent sheet-single-child-mixin))
    (declare (ignorable sheet parent))
    (values))
  
  (defmethod bury-sheet-internal (sheet (parent sheet-single-child-mixin))
    (declare (ignorable sheet parent))
    (values))
  
  (defmethod note-sheet-grafted ((sheet sheet-single-child-mixin))
    (note-sheet-grafted (first (sheet-children sheet))))
  
  (defmethod note-sheet-degrafted ((sheet sheet-single-child-mixin))
    (note-sheet-degrafted (first (sheet-children sheet))))
  
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; sheet multiple child mixin
  
  (defclass sheet-multiple-child-mixin ()
    ((children :initform nil :initarg :children :accessor sheet-children)))
  
  (defmethod sheet-adopt-child ((sheet sheet-multiple-child-mixin)
  			      (child sheet-parent-mixin))
    (when (sheet-parent child)
      (error 'sheet-already-has-parent))
    (push child (sheet-children sheet)))
  
  (defmethod sheet-adopt-child :after ((sheet sheet-multiple-child-mixin)
  				     (child sheet-parent-mixin))
    (declare (ignorable sheet))
    (note-sheet-adopted child))
  
  (defmethod sheet-disown-child ((sheet sheet-multiple-child-mixin)
  			       (child sheet-parent-mixin)
  			       &key (errorp t))
    (declare (ignorable errorp))
    (setf (sheet-children sheet) (delete child (sheet-children sheet))))
  
  (defmethod sheet-disown-child :after ((sheet sheet-multiple-child-mixin)
  				     (child sheet-parent-mixin)
  				     &key (errorp t))
    (declare (ignorable sheet errorp))
    (note-sheet-disowned child))
  
  (defmethod raise-sheet-internal (sheet (parent sheet-multiple-child-mixin))
    (setf (sheet-children parent)
  	(cons sheet (delete sheet (sheet-children parent)))))
  
  (defmethod bury-sheet-internal (sheet (parent sheet-multiple-child-mixin))
    (setf (sheet-children parent)
  	(append (delete sheet (sheet-children parent)) (list  sheet))))
  
  (defmethod note-sheet-grafted ((sheet sheet-multiple-child-mixin))
    (mapcar #'note-sheet-grafted (sheet-children sheet)))
  
  (defmethod note-sheet-degrafted ((sheet sheet-multiple-child-mixin))
    (mapcar #'note-sheet-degrafted (sheet-children sheet)))
  
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; sheet geometry classes
  
  (defclass sheet-identity-transformation-mixin ()
    ((transformation :initform +identity-transformation+
  		   :reader sheet-transformation)))
  
  (defclass sheet-translation-transformation-mixin ()
    ((transformation :initform +identity-transformation+
  		   :initarg :transformation
  		   :accessor sheet-transformation)))
  
  (defmethod (setf sheet-transformation) :before ((transformation transformation)
  						(sheet sheet-translation-transformation-mixin))
    (if (not (translation-transformation-p transformation))
        (error "Attempting to set the SHEET-TRANSFORMATION of a SHEET-TRANSLATION-TRANSFORMATION-MIXIN to a non translation transformation")))
  
  (defclass sheet-y-inverting-transformation-mixin ()
    ((transformation :initform (make-transformation 0 0 0 -1 0 0)
  		   :initarg :transformation
  		   :accessor sheet-transformation)))
  
  (defmethod (setf sheet-transformation) :before ((transformation transformation)
  						(sheet sheet-y-inverting-transformation-mixin))
    (if (not (y-inverting-transformation-p transformation))
        (error "Attempting to set the SHEET-TRANSFORMATION of a SHEET-Y-INVERTING-TRANSFORMATION-MIXIN to a non Y inverting transformation")))
  
  (defclass sheet-transformation-mixin ()
    ((transformation :initform +identity-transformation+
  		   :initarg :transformation
  		   :accessor sheet-transformation)))
  
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; mirrored sheet
  
  (defclass mirrored-sheet (sheet)
    ((port :initform nil :initarg :port :accessor port)))
  
  (defmethod sheet-direct-mirror ((sheet mirrored-sheet))
    (port-lookup-mirror (port sheet) sheet))
  
  (defmethod sheet-mirrored-ancestor ((sheet mirrored-sheet))
    sheet)
  
  (defmethod note-sheet-grafted :before ((sheet mirrored-sheet))
    (realize-mirror (port sheet) sheet))
  
  (defmethod note-sheet-degrafted :after ((sheet mirrored-sheet))
    (unrealize-mirror (port sheet) sheet))
  
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; repaint protocol classes
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; standard repaint mixin
  
  (defclass standard-repaint-mixin () ())
  
  (defmethod dispatch-repaint ((sheet standard-repaint-mixin) region)
    (queue-repaint sheet region))
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; immediate repaint mixin
  
  (defclass immediate-repaint-mixin () ())
  
  (defmethod dispatch-repaint ((sheet immediate-repaint-mixin) region)
    (handle-repaint sheet nil region))
  
  (defmethod handle-repaint ((sheet immediate-repaint-mixin) medium region)
    (declare (ignore medium region))
    (repaint-sheet sheet (sheet-region sheet))
    (loop for child in (sheet-children sheet)
  	for region = (sheet-region child)
  	do (repaint-sheet child region)))
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; mute repaint mixin
  
  (defclass mute-repaint-mixin () ())
  
  (defmethod dispatch-repaint ((sheet mute-repaint-mixin) region)
  