Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv7304

Modified Files: recording.lisp presentation-defs.lisp Log Message: Introduce a new function, highlight-output-record-tree, so that records can control how highlighting recurses into their children.

Revise definition of null output records to include any record whose upper-left and lower-right coordinates are equal. This is necessary when an empty record is transformed (such as by with-room-for-graphics).

--- /project/mcclim/cvsroot/mcclim/recording.lisp 2006/11/22 06:26:48 1.129 +++ /project/mcclim/cvsroot/mcclim/recording.lisp 2007/02/05 03:06:14 1.130 @@ -504,13 +504,26 @@ (multiple-value-bind (x1 y1 x2 y2) (output-record-hit-detection-rectangle* record) (ecase state - (:highlight + (:highlight (draw-rectangle* (sheet-medium stream) x1 y1 (1- x2) (1- y2) :filled nil :ink +foreground-ink+)) ; XXX +FLIPPING-INK+? (:unhighlight ;; FIXME: repaint the hit detection rectangle. It could be bigger than - ;;; the bounding rectangle. - (repaint-sheet stream record)))))) + ;; the bounding rectangle. + (repaint-sheet stream record) + + ;; Using queue-repaint should be faster in apps (such as clouseau) that + ;; highlight/unhighlight many bounding rectangles at once. The event + ;; code should merge these into a single larger repaint. Unfortunately, + ;; since an enqueued repaint does not occur immediately, and highlight + ;; rectangles are not recorded, newer highlighting gets wiped out + ;; shortly after being drawn. So, we aren't ready for this yet. + #+NIL + (queue-repaint stream (make-instance 'window-repaint-event + :sheet stream + :region (transform-region + (sheet-native-transformation stream) + record))))))))

;;; XXX Should this only be defined on recording streams? (defmethod highlight-output-record ((record output-record) stream state) @@ -676,8 +689,8 @@ ;;; not affect bounding rectangles. -- Hefner (defun null-bounding-rectangle-p (bbox) (with-bounding-rectangle* (x1 y1 x2 y2) bbox - (and (zerop x1) (zerop y1) - (zerop x2) (zerop y2)))) + (and (= x1 x2) + (= y1 y2))))

;;; 16.2.3. Output Record Change Notification Protocol (defmethod recompute-extent-for-new-child @@ -770,7 +783,7 @@ ;; If record is currently empty, use the child's bbox directly. Else.. ;; Does the new rectangle of the child contain the original rectangle? ;; If so, we can use min/max to grow record's current rectangle. - ;; If not, the child has shrunk, and we need to fully recompute. + ;; If not, the child has shrunk, and we need to fully recompute. (multiple-value-bind (nx1 ny1 nx2 ny2) (cond ;; The child has been deleted; who knows what the --- /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2007/01/14 19:59:07 1.69 +++ /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2007/02/05 03:06:14 1.70 @@ -1206,21 +1206,28 @@ stream state)))

+(defgeneric highlight-output-record-tree (record stream state)) + +(defmethod highlight-output-record-tree (record stream state) + (declare (ignore record stream state)) + (values)) + +(defmethod highlight-output-record-tree ((record compound-output-record) stream state) + (map-over-output-records + (lambda (record) + (highlight-output-record-tree record stream state)) + record)) + +(defmethod highlight-output-record-tree ((record displayed-output-record) stream state) + (highlight-output-record record stream state)) + (define-default-presentation-method highlight-presentation (type record stream state) (declare (ignore type)) (if (or (eq (presentation-single-box record) t) (eq (presentation-single-box record) :highlighting)) - (highlight-output-record-rectangle record stream state) - (labels ((highlighter (record) - (typecase record - (displayed-output-record - (highlight-output-record record stream state)) - (compound-output-record - (map-over-output-records #'highlighter record)) - (t nil)))) - (highlighter record)))) - + (highlight-output-record record stream state) + (highlight-output-record-tree record stream state)))

(define-default-presentation-method present (object type stream (view textual-view) &key acceptably for-context-type)