/[mcclim]/mcclim/recording.lisp
ViewVC logotype

Diff of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.139 by ahefner, Sun Feb 3 09:25:42 2008 UTC revision 1.140 by ahefner, Sun Feb 3 22:54:13 2008 UTC
# Line 397  recording stream. If it is T, *STANDARD- Line 397  recording stream. If it is T, *STANDARD-
397    (values nx ny))    (values nx ny))
398    
399  (defmethod* (setf output-record-position) :around  (defmethod* (setf output-record-position) :around
400      (nx ny (record basic-output-record))              (nx ny (record basic-output-record))
401    (with-bounding-rectangle* (min-x min-y max-x max-y) record    (with-bounding-rectangle* (min-x min-y max-x max-y) record
402      (call-next-method)      (call-next-method)
403      (let ((parent (output-record-parent record)))      (let ((parent (output-record-parent record)))
404        (when (and parent (not (and (typep parent 'compound-output-record)        (when (and parent (not (and (typep parent 'compound-output-record)
405                                    (slot-value parent 'in-moving-p)))) ; XXX                                    (slot-value parent 'in-moving-p)))) ; XXX
406          (recompute-extent-for-changed-child parent record          (recompute-extent-for-changed-child parent record
407                                              min-x min-y max-x max-y))))                                              min-x min-y max-x max-y)))
408    (values nx ny))      (values nx ny)))
409    
410  (defmethod* (setf output-record-position)  (defmethod* (setf output-record-position)
411    :before (nx ny (record compound-output-record))    :before (nx ny (record compound-output-record))
# Line 616  the associated sheet can be determined." Line 616  the associated sheet can be determined."
616      (when sheet      (when sheet
617        (map-over-output-records #'note-output-record-lost-sheet record 0 0 sheet))))        (map-over-output-records #'note-output-record-lost-sheet record 0 0 sheet))))
618    
619    (defmethod clear-output-record :around ((record compound-output-record))
620      (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* record)
621        (call-next-method)
622        (assert (null-bounding-rectangle-p record))
623        (when (output-record-parent record)
624          (recompute-extent-for-changed-child
625           (output-record-parent record) record x1 y1 x2 y2))))
626    
627  (defmethod clear-output-record :after ((record compound-output-record))  (defmethod clear-output-record :after ((record compound-output-record))
628    ;; XXX banish x and y    ;; XXX banish x and y
629    (with-slots (x y)    (with-slots (x y) record
       record  
630      (setf (rectangle-edges* record) (values x y x y))))      (setf (rectangle-edges* record) (values x y x y))))
631    
632  (defmethod output-record-count ((record displayed-output-record))  (defmethod output-record-count ((record displayed-output-record))
# Line 700  the associated sheet can be determined." Line 707  the associated sheet can be determined."
707      ((record compound-output-record) child)      ((record compound-output-record) child)
708    (unless (null-bounding-rectangle-p child)    (unless (null-bounding-rectangle-p child)
709      (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2) record      (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2) record
710        ;; I expect there's a bug here. If you create a record A, add an empty child B        (cond
711        ;; then add a displayed-output-record C, the code below will use min/max to          ((null-bounding-rectangle-p record)
712        ;; grow the all-zero bounds of A, typically giving a bogus x1,y1 of 0,0. --Hefner           (setf (rectangle-edges* record) (bounding-rectangle* child)))
713        (if (eql 1 (output-record-count record))          ((not (null-bounding-rectangle-p child))
714            (setf (rectangle-edges* record) (bounding-rectangle* child))           (assert (not (null-bounding-rectangle-p record))) ; important.
715            (with-bounding-rectangle* (x1-child y1-child x2-child y2-child)           (with-bounding-rectangle* (x1-child y1-child x2-child y2-child)
716                  child               child
717                (setf (rectangle-edges* record)             (setf (rectangle-edges* record)
718                      (values (min old-x1 x1-child) (min old-y1 y1-child)                   (values (min old-x1 x1-child) (min old-y1 y1-child)
719                              (max old-x2 x2-child) (max old-y2 y2-child)))))                           (max old-x2 x2-child) (max old-y2 y2-child))))))
720        (let ((parent (output-record-parent record)))        (let ((parent (output-record-parent record)))
721              (when parent          (when parent
722                (recompute-extent-for-changed-child            (recompute-extent-for-changed-child
723                 parent record old-x1 old-y1 old-x2 old-y2)))))             parent record old-x1 old-y1 old-x2 old-y2)))))
724    record)    record)
725    
726  (defmethod %tree-recompute-extent* ((record compound-output-record))  (defmethod %tree-recompute-extent* ((record compound-output-record))
# Line 725  the associated sheet can be determined." Line 732  the associated sheet can be determined."
732          (first-time t))          (first-time t))
733      (map-over-output-records      (map-over-output-records
734       (lambda (child)       (lambda (child)
735         (if first-time         (unless (null-bounding-rectangle-p child)
736             (progn           (if first-time
737               (multiple-value-setq (new-x1 new-y1 new-x2 new-y2)               (progn
738                 (bounding-rectangle* child))                 (multiple-value-setq (new-x1 new-y1 new-x2 new-y2)
739               (setq first-time nil))                   (bounding-rectangle* child))
740             (with-bounding-rectangle* (cx1 cy1 cx2 cy2) child                 (setq first-time nil))
741               (minf new-x1 cx1)               (with-bounding-rectangle* (cx1 cy1 cx2 cy2) child
742               (minf new-y1 cy1)                 (minf new-x1 cx1)
743               (maxf new-x2 cx2)                 (minf new-y1 cy1)
744               (maxf new-y2 cy2))))                 (maxf new-x2 cx2)
745                   (maxf new-y2 cy2)))))
746       record)       record)
747      (if first-time      (if first-time
748          ;; XXX banish x y          ;; XXX banish x y
# Line 790  the associated sheet can be determined." Line 798  the associated sheet can be determined."
798            (cond            (cond
799              ;; The child has been deleted; who knows what the              ;; The child has been deleted; who knows what the
800              ;; new bounding box might be.              ;; new bounding box might be.
801                ;; This case shouldn't be really necessary.
802              ((not (output-record-parent changed-child))              ((not (output-record-parent changed-child))
803               (%tree-recompute-extent* record))               (%tree-recompute-extent* record))
804              ;; Only one child of record, and we already have the bounds.              ;; Only one child of record, and we already have the bounds.
805              ((eql (output-record-count record) 1)              ((eql (output-record-count record) 1)
806                 ;; See output-record-children for why this assert breaks:
807                 ;; (assert (eq changed-child (elt (output-record-children record) 0)))
808               (values cx1 cy1 cx2 cy2))               (values cx1 cy1 cx2 cy2))
809              ;; If our record occupied no space (had no children, or had only              ;; If our record occupied no space (had no children, or had only
810              ;; children similarly occupying no space, hackishly determined by              ;; children similarly occupying no space, hackishly determined by
# Line 805  the associated sheet can be determined." Line 816  the associated sheet can be determined."
816              ;; In the following cases, we can grow the new bounding rectangle              ;; In the following cases, we can grow the new bounding rectangle
817              ;; from its previous state:              ;; from its previous state:
818              ((or              ((or
819                ;; If the child was originally empty, it should not have affected                ;; If the child was originally empty, it could not have affected
820                ;; previous computation of our bounding rectangle.                ;; previous computation of our bounding rectangle.
821                ;; This is hackish for reasons similar to the above.                ;; This is hackish for reasons similar to the above.
822                (and (zerop old-min-x) (zerop old-min-y)                (and (= old-min-x old-max-x) (= old-min-y old-max-y))
823                     (zerop old-max-x) (zerop old-max-y))                ;; For each edge of the original child bounds, if it was within
824                ;; For each old child coordinate, either it was not                ;; its respective edge of the old parent bounding rectangle,
825                ;; involved in determining the bounding rectangle of the                ;; or if it has not changed:
               ;; parent, or else it is the same as the corresponding  
               ;; new child coordinate.  
826                (and (or (> old-min-x ox1) (= old-min-x cx1))                (and (or (> old-min-x ox1) (= old-min-x cx1))
827                     (or (> old-min-y oy1) (= old-min-y cy1))                     (or (> old-min-y oy1) (= old-min-y cy1))
828                     (or (< old-max-x ox2) (= old-max-x cx2))                     (or (< old-max-x ox2) (= old-max-x cx2))
# Line 843  the associated sheet can be determined." Line 852  the associated sheet can be determined."
852                                                    ox1 oy1 ox2 oy2)))))))                                                    ox1 oy1 ox2 oy2)))))))
853    record)    record)
854    
 ;; 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  
   
855  (defmethod tree-recompute-extent ((record compound-output-record))  (defmethod tree-recompute-extent ((record compound-output-record))
856    (tree-recompute-extent-aux record)    (tree-recompute-extent-aux record)
857    record)    record)
# Line 989  were added." Line 993  were added."
993  (defmethod output-record-children ((record standard-tree-output-record))  (defmethod output-record-children ((record standard-tree-output-record))
994    (map 'list    (map 'list
995         #'tree-output-record-entry-record         #'tree-output-record-entry-record
996         (spatial-trees:search (%record-to-spatial-tree-rectangle record)         (spatial-trees:search
997                               (%tree-record-children record))))          (%record-to-spatial-tree-rectangle record)
998            ;; The form below intends to fix output-record-children not
999            ;; reporting empty children, which may lie outside the reported
1000            ;; bounding rectangle of their parent.
1001            ;; Assumption: null bounding records are always at the origin.
1002            ;; I've never noticed this violated, but it's out of line with
1003            ;; what null-bounding-rectangle-p checks, and setf of
1004            ;; output-record-position may invalidate it. Seems to work, but
1005            ;; fix that and try again later.
1006            #+NIL
1007            (rectangles:make-rectangle
1008             :lows (list 0 0) #| `(,(bounding-rectangle-min-x r) ,(bounding-rectangle-min-y r)) |#
1009             :highs `(,(bounding-rectangle-max-x record) ,(bounding-rectangle-max-y record)))
1010           (%tree-record-children record))))
1011    
1012  (defmethod add-output-record (child (record standard-tree-output-record))  (defmethod add-output-record (child (record standard-tree-output-record))
1013    (let ((entry (make-tree-output-record-entry child (incf (last-insertion-nr record)))))    (let ((entry (make-tree-output-record-entry child (incf (last-insertion-nr record)))))

Legend:
Removed from v.1.139  
changed lines
  Added in v.1.140

  ViewVC Help
Powered by ViewVC 1.1.5