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

Diff of /mcclim/recording.lisp

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

revision 1.38 by gilbert, Sun Apr 28 11:17:07 2002 UTC revision 1.39 by moore, Sat May 18 07:05:51 2002 UTC
# Line 72  Line 72 
72    (typep x 'output-record))    (typep x 'output-record))
73    
74  (defclass output-record-mixin (basic-output-record-mixin output-record)  (defclass output-record-mixin (basic-output-record-mixin output-record)
75    ((children :initform nil    ()
              :reader output-record-children))  
76    (:documentation "Implementation class for output records i.e., those records    (:documentation "Implementation class for output records i.e., those records
77   that have children."))   that have children."))
78    
# Line 200  Only those records that overlap REGION a Line 199  Only those records that overlap REGION a
199      (nx ny (record output-record))      (nx ny (record output-record))
200    (let ((*suppress-notify-parent* t))    (let ((*suppress-notify-parent* t))
201      (multiple-value-bind (old-x old-y) (output-record-position record)      (multiple-value-bind (old-x old-y) (output-record-position record)
202        (loop with dx = (- nx old-x)        (let ((dx (- nx old-x))
203              and dy = (- ny old-y)              (dy (- ny old-y)))
204              for child in (output-record-children record)          (map-over-output-records
205              do (multiple-value-bind (x y) (output-record-position child)           #'(lambda (child)
206                   (setf (output-record-position child)               (multiple-value-bind (x y) (output-record-position child)
207                         (values (+ x dx) (+ y dy))))))))                 (setf (output-record-position child)
208                         (values (+ x dx) (+ y dy)))))
209             record)))))
210    
211  (defmethod* (setf output-record-position) :around  (defmethod* (setf output-record-position) :around
212      (nx ny (record basic-output-record))      (nx ny (record basic-output-record))
# Line 265  Only those records that overlap REGION a Line 265  Only those records that overlap REGION a
265      ((record basic-output-record))      ((record basic-output-record))
266    (bounding-rectangle* record))    (bounding-rectangle* record))
267    
268  (defmethod output-record-refined-sensitivity-test ((record basic-output-record) x y)  (defmethod output-record-refined-position-test ((record basic-output-record)
269                                                    x y)
270    (declare (ignore x y))    (declare (ignore x y))
271    t)    t)
272    
# Line 280  Only those records that overlap REGION a Line 281  Only those records that overlap REGION a
281         (draw-rectangle* (sheet-medium stream) x1 y1 x2 y2 :filled nil :ink +background-ink+)))))         (draw-rectangle* (sheet-medium stream) x1 y1 x2 y2 :filled nil :ink +background-ink+)))))
282    
283  (defclass standard-sequence-output-record (output-record-mixin)  (defclass standard-sequence-output-record (output-record-mixin)
284    (    ((children :initform (make-array 8 :adjustable t :fill-pointer 0)
285     ))               :reader output-record-children)))
286    
287  (defclass standard-tree-output-record (output-record-mixin)  ;;; XXX bogus for now.
288    (defclass standard-tree-output-record (standard-sequence-output-record)
289    (    (
290     ))     ))
291    
# Line 293  Only those records that overlap REGION a Line 295  Only those records that overlap REGION a
295      (setq x nx      (setq x nx
296            y ny)))            y ny)))
297    
298  (defmethod output-record-children ((output-record output-record-mixin))  (defmethod add-output-record (child (record standard-sequence-output-record))
   (with-slots (children) output-record  
     (reverse children)))  
   
 (defmethod add-output-record (child (record output-record-mixin))  
299    (with-slots (children) record    (with-slots (children) record
300      (push child children))      (vector-push-extend child children))
301    (with-slots (parent) child    (with-slots (parent) child
302      (setf parent record)))      (setf parent record)))
303    
304  (defmethod add-output-record :before (child (record output-record-mixin))  (defmethod add-output-record :before (child (record output-record-mixin))
305    (when (null (output-record-children record))    (when (zerop (output-record-count record))
306      (with-slots (x1 y1 x2 y2) record      (with-slots (x1 y1 x2 y2) record
307        (setf (values x1 y1 x2 y2) (bounding-rectangle* child)))))        (setf (values x1 y1 x2 y2) (bounding-rectangle* child)))))
308    
309  (defmethod add-output-record :after (child (record output-record))  (defmethod add-output-record :after (child (record output-record))
310    (recompute-extent-for-new-child record child))    (recompute-extent-for-new-child record child))
311    
312  (defmethod delete-output-record (child (record output-record-mixin)  (defmethod delete-output-record (child (record standard-sequence-output-record)
313                                   &optional (errorp t))                                   &optional (errorp t))
314    (with-slots (children) record    (with-slots (children) record
315      (if (and errorp      (let ((pos (position child children :test #'eq)))
316               (not (member child children)))        (if (null pos)
317          (error "~S is not a child of ~S" child record))            (when errorp
318      (setq children (delete child children))))              (error "~S is not a child of ~S" child record))
319              (progn
320                (setq children (replace children children
321                                        :start1 pos
322                                        :start2 (1+ pos)))
323                (decf (fill-pointer children)))))))
324    
325  (defmethod delete-output-record :after (child (record output-record-mixin)  (defmethod delete-output-record :after (child (record output-record-mixin)
326                                          &optional (errorp t))                                          &optional (errorp t))
# Line 325  Only those records that overlap REGION a Line 328  Only those records that overlap REGION a
328    (with-bounding-rectangle* (x1 y1 x2 y2) child    (with-bounding-rectangle* (x1 y1 x2 y2) child
329      (recompute-extent-for-changed-child record child x1 y1 x2 y2)))      (recompute-extent-for-changed-child record child x1 y1 x2 y2)))
330    
331  (defmethod clear-output-record ((record output-record-mixin))  (defmethod clear-output-record ((record standard-sequence-output-record))
332    (with-slots (children x1 y1 x2 y2) record    (with-slots (children x1 y1 x2 y2) record
333      (setq children nil      (fill children nil)
334            x2 x1      (setf (fill-pointer children) 0)
335        (setq x2 x1
336            y2 y1)))            y2 y1)))
337    
338  (defmethod output-record-count ((record output-record-mixin))  (defmethod output-record-count ((record standard-sequence-output-record))
339    (length (output-record-children record)))    (length (output-record-children record)))
340    
341  (defmethod output-record-count ((record output-record))  (defmethod map-over-output-records
342    (let ((count 0))      (function (record standard-sequence-output-record)
     (map-over-output-records #'(lambda (record)  
                                  (declare (ignore record))  
                                  (incf count))  
                              record)  
     count))  
   
 (defmethod map-over-output-records (function (record output-record-mixin)  
                                     &optional (x-offset 0) (y-offset 0)  
                                     &rest function-args)  
   (declare (ignore x-offset y-offset))  
   (loop for child in (output-record-children record)  
         do (apply function child function-args)))  
   
 ;; Applies if there isn't a more specific method  
 (defmethod map-over-output-records-containing-position  
     (function (record output-record) x y  
343       &optional (x-offset 0) (y-offset 0)       &optional (x-offset 0) (y-offset 0)
344       &rest function-args)       &rest function-args)
345    (declare (ignore x-offset y-offset))    (declare (ignore x-offset y-offset))
346    (flet ((mapper (child)    (loop for child across (output-record-children record)
347             (multiple-value-bind (min-x min-y max-x max-y)          do (apply function child function-args)))
                (output-record-hit-detection-rectangle* child)  
              (when (and (<= min-x x max-x)  
                         (<= min-y y max-y)  
                         (output-record-refined-sensitivity-test child  
                                                                 x y))  
                (apply function child function-args)))))  
     (declare (dynamic-extent #'mapper))  
     (map-over-output-records #'mapper record)))  
348    
349    ;;; This needs to work in "most recently added first" order, which I
350    ;;; didn't know until recently :) -- moore
351  (defmethod map-over-output-records-containing-position  (defmethod map-over-output-records-containing-position
352      (function (record output-record-mixin) x y      (function (record standard-sequence-output-record) x y
353       &optional (x-offset 0) (y-offset 0)       &optional (x-offset 0) (y-offset 0)
354       &rest function-args)       &rest function-args)
355    (declare (ignore x-offset y-offset))    (declare (ignore x-offset y-offset))
356    (loop for child in (output-record-children record)    (with-slots (children) record
357          when (and (multiple-value-bind (min-x min-y max-x max-y)      (loop for i from (1- (length children)) downto 0
358                        (output-record-hit-detection-rectangle* child)            for child = (aref children i)
359                      (and (<= min-x x max-x) (<= min-y y max-y)))            when (and (multiple-value-bind (min-x min-y max-x max-y)
360                    (output-record-refined-sensitivity-test child x y))                          (output-record-hit-detection-rectangle* child)
361          do (apply function child function-args)))                        (and (<= min-x x max-x) (<= min-y y max-y)))
362                        (output-record-refined-position-test child x y))
363              do (apply function child function-args))))
364    
365  (defmethod map-over-output-records-overlapping-region  (defmethod map-over-output-records-overlapping-region
366      (function (record output-record) region      (function (record standard-sequence-output-record) region
367       &optional (x-offset 0) (y-offset 0)       &optional (x-offset 0) (y-offset 0)
368       &rest function-args)       &rest function-args)
369    (declare (ignore x-offset y-offset))    (declare (ignore x-offset y-offset))
370    (flet ((mapper (child)    (loop for child across (output-record-children record)
            (when (region-intersects-region-p region child)  
                (apply function child function-args))))  
     (declare (dynamic-extent #'mapper))  
     (map-over-output-records #'mapper record)))  
   
 (defmethod map-over-output-records-overlapping-region (function (record output-record) region  
                                                       &optional (x-offset 0) (y-offset 0)  
                                                       &rest function-args)  
   (declare (ignore x-offset y-offset))  
   (loop for child in (output-record-children record)  
371          do (when (region-intersects-region-p region child)          do (when (region-intersects-region-p region child)
372               (apply function child function-args))))               (apply function child function-args))))
373    
374  ;;; If the child is the only child of record, the record's bounding rectangle  ;;; If the child is the only child of record, the record's bounding rectangle
375  ;;; is set to the child's.  ;;; is set to the child's.
376  (defmethod recompute-extent-for-new-child ((record output-record-mixin) child)  (defmethod recompute-extent-for-new-child
377        ((record standard-sequence-output-record) child)
378    (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2) record    (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2) record
379      (with-slots (parent children x1 y1 x2 y2) record      (with-slots (parent children x1 y1 x2 y2) record
380        (if (null (cdr children))        (if (eql 1 (length children))
381            (setf (values x1 y1 x2 y2) (bounding-rectangle* child))            (setf (values x1 y1 x2 y2) (bounding-rectangle* child))
382            (with-bounding-rectangle* (x1-child y1-child x2-child y2-child) child            (with-bounding-rectangle* (x1-child y1-child x2-child y2-child) child
383              (minf x1 x1-child)              (minf x1 x1-child)

Legend:
Removed from v.1.38  
changed lines
  Added in v.1.39

  ViewVC Help
Powered by ViewVC 1.1.5