[mcclim-cvs] CVS mcclim
ahefner
ahefner at common-lisp.net
Sun Feb 3 22:54:14 UTC 2008
Update of /project/mcclim/cvsroot/mcclim
In directory clnet:/tmp/cvs-serv28338
Modified Files:
recording.lisp
Log Message:
Fix various bounding rectangle bugs.
1) After clear-output-record, recompute bounds of parent.
2) Fix bug in recompute-extent-for-new-child, which was noted
in the source.
3) In %tree-recompute-extent*, don't include empty rectangles.
Also twiddled comments, add assertions, and remarked on
output-record-children for tree records.
--- /project/mcclim/cvsroot/mcclim/recording.lisp 2008/02/03 09:25:42 1.139
+++ /project/mcclim/cvsroot/mcclim/recording.lisp 2008/02/03 22:54:13 1.140
@@ -397,15 +397,15 @@
(values nx ny))
(defmethod* (setf output-record-position) :around
- (nx ny (record basic-output-record))
+ (nx ny (record basic-output-record))
(with-bounding-rectangle* (min-x min-y max-x max-y) record
- (call-next-method)
+ (call-next-method)
(let ((parent (output-record-parent record)))
(when (and parent (not (and (typep parent 'compound-output-record)
(slot-value parent 'in-moving-p)))) ; XXX
(recompute-extent-for-changed-child parent record
- min-x min-y max-x max-y))))
- (values nx ny))
+ min-x min-y max-x max-y)))
+ (values nx ny)))
(defmethod* (setf output-record-position)
:before (nx ny (record compound-output-record))
@@ -616,10 +616,17 @@
(when sheet
(map-over-output-records #'note-output-record-lost-sheet record 0 0 sheet))))
+(defmethod clear-output-record :around ((record compound-output-record))
+ (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* record)
+ (call-next-method)
+ (assert (null-bounding-rectangle-p record))
+ (when (output-record-parent record)
+ (recompute-extent-for-changed-child
+ (output-record-parent record) record x1 y1 x2 y2))))
+
(defmethod clear-output-record :after ((record compound-output-record))
;; XXX banish x and y
- (with-slots (x y)
- record
+ (with-slots (x y) record
(setf (rectangle-edges* record) (values x y x y))))
(defmethod output-record-count ((record displayed-output-record))
@@ -700,20 +707,20 @@
((record compound-output-record) child)
(unless (null-bounding-rectangle-p child)
(with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2) record
- ;; I expect there's a bug here. If you create a record A, add an empty child B
- ;; then add a displayed-output-record C, the code below will use min/max to
- ;; grow the all-zero bounds of A, typically giving a bogus x1,y1 of 0,0. --Hefner
- (if (eql 1 (output-record-count record))
- (setf (rectangle-edges* record) (bounding-rectangle* child))
- (with-bounding-rectangle* (x1-child y1-child x2-child y2-child)
- child
- (setf (rectangle-edges* record)
- (values (min old-x1 x1-child) (min old-y1 y1-child)
- (max old-x2 x2-child) (max old-y2 y2-child)))))
+ (cond
+ ((null-bounding-rectangle-p record)
+ (setf (rectangle-edges* record) (bounding-rectangle* child)))
+ ((not (null-bounding-rectangle-p child))
+ (assert (not (null-bounding-rectangle-p record))) ; important.
+ (with-bounding-rectangle* (x1-child y1-child x2-child y2-child)
+ child
+ (setf (rectangle-edges* record)
+ (values (min old-x1 x1-child) (min old-y1 y1-child)
+ (max old-x2 x2-child) (max old-y2 y2-child))))))
(let ((parent (output-record-parent record)))
- (when parent
- (recompute-extent-for-changed-child
- parent record old-x1 old-y1 old-x2 old-y2)))))
+ (when parent
+ (recompute-extent-for-changed-child
+ parent record old-x1 old-y1 old-x2 old-y2)))))
record)
(defmethod %tree-recompute-extent* ((record compound-output-record))
@@ -725,16 +732,17 @@
(first-time t))
(map-over-output-records
(lambda (child)
- (if first-time
- (progn
- (multiple-value-setq (new-x1 new-y1 new-x2 new-y2)
- (bounding-rectangle* child))
- (setq first-time nil))
- (with-bounding-rectangle* (cx1 cy1 cx2 cy2) child
- (minf new-x1 cx1)
- (minf new-y1 cy1)
- (maxf new-x2 cx2)
- (maxf new-y2 cy2))))
+ (unless (null-bounding-rectangle-p child)
+ (if first-time
+ (progn
+ (multiple-value-setq (new-x1 new-y1 new-x2 new-y2)
+ (bounding-rectangle* child))
+ (setq first-time nil))
+ (with-bounding-rectangle* (cx1 cy1 cx2 cy2) child
+ (minf new-x1 cx1)
+ (minf new-y1 cy1)
+ (maxf new-x2 cx2)
+ (maxf new-y2 cy2)))))
record)
(if first-time
;; XXX banish x y
@@ -790,10 +798,13 @@
(cond
;; The child has been deleted; who knows what the
;; new bounding box might be.
+ ;; This case shouldn't be really necessary.
((not (output-record-parent changed-child))
(%tree-recompute-extent* record))
;; Only one child of record, and we already have the bounds.
((eql (output-record-count record) 1)
+ ;; See output-record-children for why this assert breaks:
+ ;; (assert (eq changed-child (elt (output-record-children record) 0)))
(values cx1 cy1 cx2 cy2))
;; If our record occupied no space (had no children, or had only
;; children similarly occupying no space, hackishly determined by
@@ -805,15 +816,13 @@
;; In the following cases, we can grow the new bounding rectangle
;; from its previous state:
((or
- ;; If the child was originally empty, it should not have affected
+ ;; If the child was originally empty, it could not have affected
;; previous computation of our bounding rectangle.
;; This is hackish for reasons similar to the above.
- (and (zerop old-min-x) (zerop old-min-y)
- (zerop old-max-x) (zerop old-max-y))
- ;; For each old child coordinate, either it was not
- ;; involved in determining the bounding rectangle of the
- ;; parent, or else it is the same as the corresponding
- ;; new child coordinate.
+ (and (= old-min-x old-max-x) (= old-min-y old-max-y))
+ ;; For each edge of the original child bounds, if it was within
+ ;; its respective edge of the old parent bounding rectangle,
+ ;; or if it has not changed:
(and (or (> old-min-x ox1) (= old-min-x cx1))
(or (> old-min-y oy1) (= old-min-y cy1))
(or (< old-max-x ox2) (= old-max-x cx2))
@@ -843,11 +852,6 @@
ox1 oy1 ox2 oy2)))))))
record)
-;; There was once an :around method on recompute-extent-for-changed-child here,
-;; but I've eliminated it. Its function was to notify the parent OR in case
-;; the bounding rect here changed - I've merged this into the above method.
-;; --Hefner, 8/7/02
-
(defmethod tree-recompute-extent ((record compound-output-record))
(tree-recompute-extent-aux record)
record)
@@ -989,8 +993,21 @@
(defmethod output-record-children ((record standard-tree-output-record))
(map 'list
#'tree-output-record-entry-record
- (spatial-trees:search (%record-to-spatial-tree-rectangle record)
- (%tree-record-children record))))
+ (spatial-trees:search
+ (%record-to-spatial-tree-rectangle record)
+ ;; The form below intends to fix output-record-children not
+ ;; reporting empty children, which may lie outside the reported
+ ;; bounding rectangle of their parent.
+ ;; Assumption: null bounding records are always at the origin.
+ ;; I've never noticed this violated, but it's out of line with
+ ;; what null-bounding-rectangle-p checks, and setf of
+ ;; output-record-position may invalidate it. Seems to work, but
+ ;; fix that and try again later.
+ #+NIL
+ (rectangles:make-rectangle
+ :lows (list 0 0) #| `(,(bounding-rectangle-min-x r) ,(bounding-rectangle-min-y r)) |#
+ :highs `(,(bounding-rectangle-max-x record) ,(bounding-rectangle-max-y record)))
+ (%tree-record-children record))))
(defmethod add-output-record (child (record standard-tree-output-record))
(let ((entry (make-tree-output-record-entry child (incf (last-insertion-nr record)))))
More information about the Mcclim-cvs
mailing list