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

Diff of /mcclim/recording.lisp

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

revision 1.33 by gilbert, Mon Feb 11 21:47:49 2002 UTC revision 1.34 by moore, Wed Apr 3 02:36:59 2002 UTC
# Line 34  Line 34 
34    
35  (in-package :CLIM-INTERNALS)  (in-package :CLIM-INTERNALS)
36    
37  (defclass output-record-mixin ()  ;;; Should we blow off standard-bounding-rectangle and implement the
38    ;;; bounding rectangle protocol ourselves?  Or use x1,y1 from
39    ;;; standard-bounding-rectangle as our position?
40    
41    (defclass basic-output-record (bounding-rectangle)
42      ()
43      (:documentation "Internal protocol class for common elements of output-record
44     and displayed-output-record"))
45    
46    (defclass basic-output-record-mixin (standard-bounding-rectangle
47                                         basic-output-record)
48    ((x :initarg :x-position    ((x :initarg :x-position
49        :initform 0        :initform 0
50        :type rational)        :type rational)
# Line 43  Line 53 
53        :type rational)        :type rational)
54     (parent :initarg :parent     (parent :initarg :parent
55             :initform nil             :initform nil
56             :reader output-record-parent)))             :reader output-record-parent))
57      (:documentation "Implementation class for the Basic Output Record Protocol"))
58    
59  (defmethod initialize-instance :after ((record output-record-mixin) &rest args)  (defmethod initialize-instance :after ((record basic-output-record-mixin)
60                                           &rest args)
61    (declare (ignore args))    (declare (ignore args))
62    (with-slots (x1 y1 x2 y2) record    (with-slots (x y x1 y1 x2 y2) record
63      (setq x1 0      (setq x1 x
64            y1 0            y1 y
65            x2 0            x2 x
66            y2 0)))            y2 y)))
67    
68  (defclass output-record (standard-bounding-rectangle output-record-mixin)  (defclass output-record (basic-output-record)
69    ((children :initform nil    ())
              :reader output-record-children))  
   (:default-initargs :min-x 0 :min-y 0 :max-x 0 :max-y 0))  
70    
71  (defun output-record-p (x)  (defun output-record-p (x)
72    (typep x 'output-record))    (typep x 'output-record))
73    
74  (defclass displayed-output-record (standard-bounding-rectangle output-record-mixin)  (defclass output-record-mixin (basic-output-record-mixin output-record)
75      ((children :initform nil
76                 :reader output-record-children))
77      (:documentation "Implementation class for output records i.e., those records
78     that have children."))
79    
80    (defclass displayed-output-record (basic-output-record)
81      ())
82    
83    (defclass displayed-output-record-mixin (basic-output-record-mixin
84                                             displayed-output-record)
85    ((ink :initarg :ink :reader displayed-output-record-ink)    ((ink :initarg :ink :reader displayed-output-record-ink)
86     (initial-x1 :initarg :initial-x1)     (initial-x1 :initarg :initial-x1)
87     (initial-y1 :initarg :initial-y1)))     (initial-y1 :initarg :initial-y1))
88      (:documentation "Implementation class for displayed-output-record."))
89    
90  (defun displayed-output-record-p (x)  (defun displayed-output-record-p (x)
91    (typep x 'displayed-output-record))    (typep x 'displayed-output-record))
# Line 142  Only those records that overlap REGION a Line 163  Only those records that overlap REGION a
163  (defgeneric map-over-output-records-overlapping-region  (defgeneric map-over-output-records-overlapping-region
164    (function record region &optional x-offset y-offset &rest function-args))    (function record region &optional x-offset y-offset &rest function-args))
165    
166    ;;; From the Franz CLIM user's guide but not in the spec... clearly necessary.
167    (defgeneric map-over-output-records
168        (continuation record &optional x-offset y-offset &rest continuation-args))
169    
170  ; 16.2.3. Output Record Change Notification Protocol  ; 16.2.3. Output Record Change Notification Protocol
171    
172  (defgeneric recompute-extent-for-new-child (record child))  (defgeneric recompute-extent-for-new-child (record child))
# Line 153  Only those records that overlap REGION a Line 178  Only those records that overlap REGION a
178    
179  ;;; Methods  ;;; Methods
180    
181  (defmethod initialize-instance :after ((record output-record) &rest args  (defmethod output-record-position ((record basic-output-record-mixin))
                                        &key size  
                                        &allow-other-keys)  
   (declare (ignore args size)))  
   
 (defmethod output-record-position ((record output-record-mixin))  
182    (with-slots (x y) record    (with-slots (x y) record
183      (values x y)))      (values x y)))
184    
185  (defmethod* (setf output-record-position) (nx ny (record output-record-mixin))  (defvar *suppress-notify-parent* nil
186      "When t, don't notify the parent of a change in an output record's
187       bounding rectangle.")
188    
189    (defmethod* (setf output-record-position)
190        (nx ny (record basic-output-record-mixin))
191    (with-slots (x y x1 y1 x2 y2) record    (with-slots (x y x1 y1 x2 y2) record
192      (let ((dx (- nx x))      (let ((dx (- nx x))
193            (dy (- ny y)))            (dy (- ny y)))
# Line 171  Only those records that overlap REGION a Line 196  Only those records that overlap REGION a
196      (setq x nx      (setq x nx
197            y ny)))            y ny)))
198    
199  (defmethod* (setf output-record-position) :before (nx ny (record output-record))  (defmethod* (setf output-record-position) :before
200    (multiple-value-bind (old-x old-y) (output-record-position record)      (nx ny (record output-record))
201      (loop with dx = (- nx old-x)    (let ((*suppress-notify-parent* t))
202            and dy = (- ny old-y)      (multiple-value-bind (old-x old-y) (output-record-position record)
203            for child in (output-record-children record)        (loop with dx = (- nx old-x)
204            do (multiple-value-bind (x y) (output-record-position child)              and dy = (- ny old-y)
205                 (setf (output-record-position child) (values (+ x dx) (+ y dy)))))))              for child in (output-record-children record)
206                do (multiple-value-bind (x y) (output-record-position child)
207                     (setf (output-record-position child)
208                           (values (+ x dx) (+ y dy))))))))
209    
210    
211  (defmethod* (setf output-record-position) :around (nx ny (record output-record-mixin))  (defmethod* (setf output-record-position) :around
212        (nx ny (record basic-output-record))
213    (declare (ignore nx ny))    (declare (ignore nx ny))
214    (with-bounding-rectangle* (min-x min-y max-x max-y) record    (if *suppress-notify-parent*
215      (call-next-method)        (call-next-method)
216      (let ((parent (output-record-parent record)))        (with-bounding-rectangle* (min-x min-y max-x max-y) record
217        (when parent          (call-next-method)
218          (recompute-extent-for-changed-child parent record          (let ((parent (output-record-parent record)))
219                                              min-x min-y max-x max-y)))))            (when parent
220                (recompute-extent-for-changed-child parent record
221                                                    min-x min-y max-x max-y))))))
222    
223    
224  (defmethod output-record-start-cursor-position ((record displayed-output-record))  (defmethod output-record-start-cursor-position ((record basic-output-record))
225    (values nil nil))    (values nil nil))
226    
227  (defmethod* (setf output-record-start-cursor-position) (x y (record displayed-output-record))  (defmethod* (setf output-record-start-cursor-position)
228        (x y (record basic-output-record))
229    (declare (ignore x y))    (declare (ignore x y))
230    nil)    nil)
231    
232  (defmethod output-record-end-cursor-position ((record displayed-output-record))  (defmethod output-record-end-cursor-position ((record basic-output-record))
233    (values nil nil))    (values nil nil))
234    
235  (defmethod* (setf output-record-end-cursor-position) (x y (record displayed-output-record))  (defmethod* (setf output-record-end-cursor-position)
236        (x y (record basic-output-record))
237    (declare (ignore x y))    (declare (ignore x y))
238    nil)    nil)
239    
# Line 216  Only those records that overlap REGION a Line 251  Only those records that overlap REGION a
251                                   &optional region (x-offset 0) (y-offset 0))                                   &optional region (x-offset 0) (y-offset 0))
252    (when (null region)    (when (null region)
253      (setq region +everywhere+))      (setq region +everywhere+))
254    (map-over-output-records-overlaping-region    (map-over-output-records-overlapping-region
255     #'replay-output-record record region x-offset y-offset     #'replay-output-record record region x-offset y-offset
256     stream region x-offset y-offset))     stream region x-offset y-offset))
257    
258    ;;; XXX ? should this be defined on output-record at all?
259    ;;; Probably not -- moore
260  (defmethod erase-output-record ((record output-record) stream &optional (errorp t))  (defmethod erase-output-record ((record output-record) stream &optional (errorp t))
261    (declare (ignore stream errorp))    (declare (ignore stream errorp))
262    nil)    nil)
263    
264  (defmethod output-record-hit-detection-rectangle* ((record output-record-mixin))  (defmethod output-record-hit-detection-rectangle*
265        ((record basic-output-record))
266    (bounding-rectangle* record))    (bounding-rectangle* record))
267    
268  (defmethod output-record-refined-sensitivity-test ((record output-record-mixin) x y)  (defmethod output-record-refined-sensitivity-test ((record basic-output-record) x y)
269    (declare (ignore x y))    (declare (ignore x y))
270    t)    t)
271    
272  (defmethod highlight-output-record ((record output-record-mixin) stream state)  ;;; XXX Should this only be defined on recording streams?
273    (defmethod highlight-output-record ((record basic-output-record-mixin)
274                                        stream state)
275    (multiple-value-bind (x1 y1 x2 y2) (output-record-hit-detection-rectangle* record)    (multiple-value-bind (x1 y1 x2 y2) (output-record-hit-detection-rectangle* record)
276      (ecase state      (ecase state
277        (:highlight        (:highlight
# Line 239  Only those records that overlap REGION a Line 279  Only those records that overlap REGION a
279        (:unhighlight        (:unhighlight
280         (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+)))))
281    
282  (defclass standard-sequence-output-record (output-record)  (defclass standard-sequence-output-record (output-record-mixin)
283    (    (
284     ))     ))
285    
286  (defclass standard-tree-output-record (output-record)  (defclass standard-tree-output-record (output-record-mixin)
287    (    (
288     ))     ))
289    
290    #+nil
291  (defmethod* (setf output-record-position) (nx ny (record standard-sequence-output-record))  (defmethod* (setf output-record-position) (nx ny (record standard-sequence-output-record))
292    (with-slots (x y) record    (with-slots (x y) record
293      (setq x nx      (setq x nx
294            y ny)))            y ny)))
295    
296  (defmethod output-record-children ((output-record output-record))  (defmethod output-record-children ((output-record output-record-mixin))
297    (with-slots (children) output-record    (with-slots (children) output-record
298      (reverse children)))      (reverse children)))
299    
300  (defmethod add-output-record (child (record output-record))  (defmethod add-output-record (child (record output-record-mixin))
301    (with-slots (children) record    (with-slots (children) record
302      (push child children))      (push child children))
303    (with-slots (parent) child    (with-slots (parent) child
304      (setf parent record)))      (setf parent record)))
305    
306  (defmethod add-output-record :before (child (record output-record))  (defmethod add-output-record :before (child (record output-record-mixin))
307    (when (null (output-record-children record))    (when (null (output-record-children record))
308      (with-bounding-rectangle* (min-x min-y max-x max-y) child      (with-bounding-rectangle* (min-x min-y max-x max-y) child
309      (with-slots (x1 y1 x2 y2) record      (with-slots (x1 y1 x2 y2) record
# Line 274  Only those records that overlap REGION a Line 315  Only those records that overlap REGION a
315  (defmethod add-output-record :after (child (record output-record))  (defmethod add-output-record :after (child (record output-record))
316    (recompute-extent-for-new-child record child))    (recompute-extent-for-new-child record child))
317    
318  (defmethod delete-output-record (child (record output-record) &optional (errorp t))  (defmethod delete-output-record (child (record output-record-mixin)
319                                     &optional (errorp t))
320    (with-slots (children) record    (with-slots (children) record
321      (if (and errorp      (if (and errorp
322               (not (member child children)))               (not (member child children)))
323          (error "~S is not a child of ~S" child record))          (error "~S is not a child of ~S" child record))
324      (setq children (delete child children))))      (setq children (delete child children))))
325    
326  (defmethod delete-output-record :after (child (record output-record) &optional (errorp t))  (defmethod delete-output-record :after (child (record output-record-mixin)
327                                            &optional (errorp t))
328    (declare (ignore errorp))    (declare (ignore errorp))
329    (with-bounding-rectangle* (x1 y1 x2 y2) child    (with-bounding-rectangle* (x1 y1 x2 y2) child
330      (recompute-extent-for-changed-child record child x1 y1 x2 y2)))      (recompute-extent-for-changed-child record child x1 y1 x2 y2)))
331    
332  (defmethod clear-output-record ((record output-record))  (defmethod clear-output-record ((record output-record-mixin))
333    (with-slots (children x1 y1 x2 y2) record    (with-slots (children x1 y1 x2 y2) record
334      (setq children nil      (setq children nil
335            x1 (coordinate 0)            x2 x1
336            y1 (coordinate 0)            y2 y1)))
           x2 (coordinate 0)  
           y2 (coordinate 0))))  
337    
338  (defmethod output-record-count ((record output-record))  (defmethod output-record-count ((record output-record-mixin))
339    (length (output-record-children record)))    (length (output-record-children record)))
340    
341    (defmethod map-over-output-records (function (record output-record-mixin)
342                                        &optional (x-offset 0) (y-offset 0)
343                                        &rest function-args)
344      (declare (dynamic-extent function)
345               (ignore x-offset y-offset))
346      (loop for child in (output-record-children record)
347            do (apply function child function-args)))
348    
349  (defmethod map-over-output-records-containing-position (function (record output-record) x y  (defmethod map-over-output-records-containing-position (function (record output-record) x y
350                                                          &optional (x-offset 0) (y-offset 0)                                                          &optional (x-offset 0) (y-offset 0)
351                                                          &rest function-args)                                                          &rest function-args)
352    (declare (dynamic-extent function)    (declare (dynamic-extent function)
353             (ignore x-offset y-offset))             (ignore x-offset y-offset))
354    (loop for child in (output-record-children record)    (loop for child in (output-record-children record)
355          when (and (region-contains-position-p          when (and (multiple-value-bind (min-x min-y max-x max-y)
356                     (multiple-value-call #'make-bounding-rectangle                        (output-record-hit-detection-rectangle* child)
357                       (output-record-hit-detection-rectangle* child))                      (and (<= min-x x max-x) (<= min-y y max-y)))
                    x y)  
358                    (output-record-refined-sensitivity-test child x y))                    (output-record-refined-sensitivity-test child x y))
359          do (apply function child function-args)))          do (apply function child function-args)))
360    
361  (defmethod map-over-output-records-overlaping-region (function (record output-record) region  (defmethod map-over-output-records-overlapping-region (function (record output-record) region
362                                                        &optional (x-offset 0) (y-offset 0)                                                        &optional (x-offset 0) (y-offset 0)
363                                                        &rest function-args)                                                        &rest function-args)
364    (declare (dynamic-extent function)    (declare (dynamic-extent function)
# Line 319  Only those records that overlap REGION a Line 367  Only those records that overlap REGION a
367          do (when (region-intersects-region-p region child)          do (when (region-intersects-region-p region child)
368               (apply function child function-args))))               (apply function child function-args))))
369    
370  (defmethod recompute-extent-for-new-child ((record output-record) child)  ;;; If the child is the only child of record, the record's bounding rectangle
371    ;;; is set to the child's.
372    (defmethod recompute-extent-for-new-child ((record output-record-mixin) child)
373    (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2) record    (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2) record
374      (with-slots (parent x1 y1 x2 y2) record      (with-slots (parent children x1 y1 x2 y2) record
375        (with-bounding-rectangle* (x1-child y1-child x2-child y2-child) child        (if (null (cdr children))
376          (setq x1 (min x1 x1-child)            (setf (values x1 y1 x2 y2) (bounding-rectangle* child))
377                y1 (min y1 y1-child)            (with-bounding-rectangle* (x1-child y1-child x2-child y2-child) child
378                x2 (max x2 x2-child)              (minf x1 x1-child)
379                y2 (max y2 y2-child)))              (minf y1 y1-child)
380                (maxf x2 x2-child)
381                (maxf y2 y2-child)))
382        (when parent        (when parent
383          (recompute-extent-for-changed-child parent record old-x1 old-y1 old-x2 old-y2)))))          (recompute-extent-for-changed-child parent record
384                                                old-x1 old-y1 old-x2 old-y2)))))
385    
386  (defmethod recompute-extent-for-changed-child :around ((record output-record) child  (defmethod recompute-extent-for-changed-child :around
387                                                         old-min-x old-min-y old-max-x old-max-y)      ((record basic-output-record-mixin) child
388         old-min-x old-min-y old-max-x old-max-y)
389    (declare (ignore child old-min-x old-min-y old-max-x old-max-y))    (declare (ignore child old-min-x old-min-y old-max-x old-max-y))
390    (let ((old-rectangle (multiple-value-call #'make-bounding-rectangle    (let ((old-rectangle (multiple-value-call #'make-bounding-rectangle
391                           (bounding-rectangle* record))))                           (bounding-rectangle* record))))
# Line 340  Only those records that overlap REGION a Line 394  Only those records that overlap REGION a
394        (when (and parent (not (region-equal old-rectangle record)))        (when (and parent (not (region-equal old-rectangle record)))
395          (recompute-extent-for-changed-child parent record x1 y1 x2 y2)))))          (recompute-extent-for-changed-child parent record x1 y1 x2 y2)))))
396    
397  (defmethod recompute-extent-for-changed-child ((record output-record) changed-child  ;; Internal helper function
398                                                 old-min-x old-min-y old-max-x old-max-y)  (defmethod %tree-recompute-extent* ((record output-record))
399    (with-slots (children x1 y1 x2 y2) record    (let ((new-x1 0)
400      (with-bounding-rectangle* (new-x1 new-y1 new-x2 new-y2) changed-child          (new-y1 0)
401        (setq x1 (min x1 new-x1)          (new-x2 0)
402              y1 (min y1 new-y1)          (new-y2 0)
403              x2 (max x2 new-x2)          (first-time t))
404              y2 (max y2 new-y2)))      (map-over-output-records
405      (if (null children)       #'(lambda (child)
406          (clear-output-record record)           (if first-time
407          (when (or (coordinate= x1 old-min-x)               (progn
408                    (coordinate= y1 old-min-y)                 (setf (values new-x1 new-y1 new-x2 new-y2)
409                    (coordinate= x2 old-max-x)                       (bounding-rectangle* child))
410                    (coordinate= y2 old-max-y))                 (setq first-time nil))
411            (with-bounding-rectangle* (left top right bottom) (first children)               (with-bounding-rectangle* (cx1 cy1 cx2 cy2) child
412              (loop for child in (rest children)                 (minf new-x1 cx1)
413                    do (with-bounding-rectangle* (x1-child y1-child x2-child y2-child) child                 (minf new-y1 cy1)
414                         (setq left (min left x1-child)                 (maxf new-x2 cx2)
415                               top  (min top y1-child)                 (maxf new-y2 cy2))))
416                               right  (max right x2-child)       record)
417                               bottom (max bottom y2-child))))      ;; If we don't have any children, collapse the bbox to the min point.
418              (setq x1 left      (if first-time
419                    y1 top          (with-bounding-rectangle* (x1 y1 x2 y2) record
420                    x2 right            (values x1 y1 x1 y1))
421                    y2 bottom))))))          (values new-x1 new-y1 new-x2 new-y2))))
422    
423    (defmethod recompute-extent-for-changed-child
424        ((record output-record-mixin) changed-child
425         old-min-x old-min-y old-max-x old-max-y)
426      ;; If the child's old and new bbox lies entirely within the record's bbox
427      ;; then no change need be made to the record's bbox.  Otherwise, if some part
428      ;; of the child's bbox was on the record's bbox and is now inside, examine
429      ;; all the children to determine the correct new bbox.
430      (with-slots (x1 y1 x2 y2) record
431        (with-bounding-rectangle* (child-x1 child-y1 child-x2 child-y2)
432            changed-child
433          (unless (and (> x1 old-min-x)
434                       (> y1 old-min-y)
435                       (< x2 old-max-x)
436                       (< y2 old-max-y)
437                       (> x1 child-x1)
438                       (> y1 child-y1)
439                       (< x2 child-x2)
440                       (< y2 child-y2))
441            ;; Don't know if changed-child has been deleted or what, so go through
442            ;; all the children and construct the updated bbox.
443            (setf (values x1 y1 x2 y2) (%tree-recompute-extent* record))
444            nil))))
445    
446    (defmethod tree-recompute-extent ((record output-record-mixin))
447      (with-slots (x1 y1 x2 y2) record
448        (setf (values x1 y1 x2 y2) (%tree-recompute-extent* record))
449        nil))
450    
 (defmethod tree-recompute-extent ((record output-record))  
   (with-slots (children x1 y1 x2 y2) record  
     (if (null children)  
         (setq x1 (coordinate 0)  
               y1 (coordinate 0)  
               x2 (coordinate 0)  
               y2 (coordinate 0))  
       (with-bounding-rectangle* (left top right bottom) (first children)  
         (loop for child in (rest children)  
               do (with-bounding-rectangle* (l1 t1 r1 b1) child  
                    (setq left (min left l1 r1)  
                          top (min top t1 b1)  
                          right (max right l1 r1)  
                          bottom (max bottom t1 b1))))  
         (setq x1 left  
               y1 top  
               x2 right  
               y2 bottom)))))  
451    
452  (defmethod tree-recompute-extent :around ((record output-record))  (defmethod tree-recompute-extent :around ((record output-record))
453    (let ((old-rectangle (multiple-value-call #'make-bounding-rectangle    (let ((old-rectangle (multiple-value-call #'make-bounding-rectangle
# Line 397  Only those records that overlap REGION a Line 461  Only those records that overlap REGION a
461  ;;; Graphics recording classes  ;;; Graphics recording classes
462    
463  (defclass graphics-displayed-output-record (displayed-output-record)  (defclass graphics-displayed-output-record (displayed-output-record)
464      ())
465    
466    (defclass graphics-displayed-output-record-mixin
467        (displayed-output-record-mixin graphics-displayed-output-record)
468    ((clip :initarg :clipping-region    ((clip :initarg :clipping-region
469           :documentation "Clipping region in user coordinates.")           :documentation "Clipping region in user coordinates.")
470     (transform :initarg :transformation)     (transform :initarg :transformation)
# Line 423  Only those records that overlap REGION a Line 491  Only those records that overlap REGION a
491  ;;; Output-Recording-Stream class  ;;; Output-Recording-Stream class
492    
493  (defclass output-recording-stream ()  (defclass output-recording-stream ()
494    ((recording-p :initform t :accessor stream-recording-p)    ())
495    
496    (defun output-recording-stream-p (x)
497      (typep x 'output-recording-stream))
498    
499    (defclass standard-output-recording-stream (output-recording-stream)
500      ((recording-p :initform t :reader stream-recording-p)
501     (drawing-p :initform t :accessor stream-drawing-p)     (drawing-p :initform t :accessor stream-drawing-p)
502     (output-history :initform (make-instance 'standard-tree-output-history)     (output-history :initform (make-instance 'standard-tree-output-history)
503                     :reader stream-output-history)                     :reader stream-output-history)
# Line 432  Only those records that overlap REGION a Line 506  Only those records that overlap REGION a
506     (local-record-p :initform t     (local-record-p :initform t
507                     :documentation "This flag is used for dealing with streams outputting strings char-by-char.")))                     :documentation "This flag is used for dealing with streams outputting strings char-by-char.")))
508    
 (defun output-recording-stream-p (x)  
   (typep x 'output-recording-stream))  
   
 (defclass standard-output-recording-stream (output-recording-stream)  
   (  
    ))  
   
509  ;;; 16.4.1 The Output Recording Stream Protocol  ;;; 16.4.1 The Output Recording Stream Protocol
510  (defgeneric stream-recording-p (stream))  (defgeneric stream-recording-p (stream))
511    
# Line 462  Only those records that overlap REGION a Line 529  Only those records that overlap REGION a
529    
530  (defgeneric copy-textual-output-history (window stream &optional region record))  (defgeneric copy-textual-output-history (window stream &optional region record))
531    
532    (defmethod (setf stream-recording-p)
533        (recording-p (stream standard-output-recording-stream))
534      (let ((old-val (slot-value stream 'recording-p)))
535        (setf (slot-value stream 'recording-p) recording-p)
536        (when (not (eql old-val recording-p))
537          (stream-close-text-output-record stream))
538        recording-p))
539    
540  ;;; 16.4.3 Text Output Recording  ;;; 16.4.3 Text Output Recording
541    
542  (defgeneric stream-text-output-record (stream text-style))  (defgeneric stream-text-output-record (stream text-style))
# Line 485  Only those records that overlap REGION a Line 560  Only those records that overlap REGION a
560  (defmethod stream-replay ((stream output-recording-stream) &optional region)  (defmethod stream-replay ((stream output-recording-stream) &optional region)
561    (replay (stream-output-history stream) stream region))    (replay (stream-output-history stream) stream region))
562    
563  (defmacro with-output-recording-options ((stream &key (record t) (draw t)) &body body)  (defmacro with-output-recording-options ((stream
564                                              &key (record nil record-supplied-p)
565                                                   (draw nil draw-supplied-p))
566                                             &body body)
567    (declare (type symbol stream))    (declare (type symbol stream))
568    (when (eq stream 't)    (when (eq stream 't)
569      (setq stream '*standard-output*))      (setq stream '*standard-output*))
570    (let ((continuation-name (gensym)))    (let ((continuation-name (gensym "WITH-OUTPUT-RECORDING-OPTIONS")))
571      `(let ((,continuation-name #'(lambda (,stream) ,@body)))      `(flet ((,continuation-name  (,stream) ,@body))
572           (declare (dynamic-extent ,continuation-name))
573         (invoke-with-output-recording-options ,stream         (invoke-with-output-recording-options ,stream
574                                               ,continuation-name                                               #',continuation-name
575                                               ,record                                               ,(if record-supplied-p
576                                               ,draw))))                                                    record
577                                                      `(stream-recording-p
578                                                        ,stream))
579                                                 ,(if draw-supplied-p
580                                                      draw
581                                                      `(stream-drawing-p
582                                                        ,stream))))))
583    
584    
585  (defmethod invoke-with-output-recording-options  (defmethod invoke-with-output-recording-options
586    ((stream output-recording-stream) continuation record draw)    ((stream output-recording-stream) continuation record draw)
587    "Calls CONTINUATION on STREAM enabling or disabling recording and drawing    "Calls CONTINUATION on STREAM enabling or disabling recording and drawing
588  according to the flags RECORD and DRAW."  according to the flags RECORD and DRAW."
589    (declare (dynamic-extent continuation))    (declare (dynamic-extent continuation))
590    (with-slots (recording-p drawing-p) stream    (letf (((stream-recording-p stream) record)
591                (unless (eq recording-p record)           ((stream-drawing-p stream) draw))
592                  (stream-close-text-output-record stream))      (funcall continuation stream)))
               (letf ((recording-p record)  
                      (drawing-p draw))  
                 (funcall continuation stream))))  
593    
594  (defmacro with-new-output-record ((stream  (defmacro with-new-output-record ((stream
595                                     &optional                                     &optional
# Line 587  recording stream. If it is T, *STANDARD- Line 670  recording stream. If it is T, *STANDARD-
670    
671  ;;; Graphics and text recording classes  ;;; Graphics and text recording classes
672    
673  (eval-when (compile load eval)  (eval-when (:compile-toplevel :load-toplevel :execute)
674    
675    (defun compute-class-vars (names)    (defun compute-class-vars (names)
676      (cons (list 'stream :initarg :stream)      (cons (list 'stream :initarg :stream)
# Line 616  recording stream. If it is T, *STANDARD- Line 699  recording stream. If it is T, *STANDARD-
699          (new-medium (gensym))          (new-medium (gensym))
700          (border (gensym)))          (border (gensym)))
701      `(progn      `(progn
702         (defclass ,class-name (graphics-displayed-output-record)         (defclass ,class-name (graphics-displayed-output-record-mixin)
703           ,(compute-class-vars args))           ,(compute-class-vars args))
704         (defmethod initialize-instance :after ((graphic ,class-name) &rest args)         (defmethod initialize-instance :after ((graphic ,class-name) &rest args)
705           (declare (ignore args))           (declare (ignore args))
# Line 757  recording stream. If it is T, *STANDARD- Line 840  recording stream. If it is T, *STANDARD-
840  ;;; Text recording class  ;;; Text recording class
841    
842  (defclass text-displayed-output-record (displayed-output-record)  (defclass text-displayed-output-record (displayed-output-record)
843      ())
844    
845    (defclass text-displayed-output-record-mixin
846        (text-displayed-output-record displayed-output-record-mixin)
847    ((strings :initform nil)    ((strings :initform nil)
848     (baseline :initform 0)     (baseline :initform 0)
849     (width :initform 0)     (width :initform 0)
# Line 771  recording stream. If it is T, *STANDARD- Line 858  recording stream. If it is T, *STANDARD-
858  (defun text-displayed-output-record-p (x)  (defun text-displayed-output-record-p (x)
859    (typep x 'text-displayed-output-record))    (typep x 'text-displayed-output-record))
860    
861  (defmethod print-object ((self text-displayed-output-record) stream)  (defmethod print-object ((self text-displayed-output-record-mixin) stream)
862    (print-unreadable-object (self stream :type t :identity t)    (print-unreadable-object (self stream :type t :identity t)
863      (if (slot-boundp self 'start-x)      (if (slot-boundp self 'start-x)
864          (with-slots (start-x start-y strings) self          (with-slots (start-x start-y strings) self
# Line 785  recording stream. If it is T, *STANDARD- Line 872  recording stream. If it is T, *STANDARD-
872  (defgeneric text-displayed-output-record-string (text-record))  (defgeneric text-displayed-output-record-string (text-record))
873    
874  ;;; Methods  ;;; Methods
875  (defmethod tree-recompute-extent ((text-record text-displayed-output-record))  (defmethod tree-recompute-extent
876        ((text-record text-displayed-output-record-mixin))
877    (with-slots (parent x y    (with-slots (parent x y
878                        x1 y1 x2 y2 width max-height) text-record                        x1 y1 x2 y2 width max-height) text-record
879                (setq x1 (coordinate x)                (setq x1 (coordinate x)
# Line 793  recording stream. If it is T, *STANDARD- Line 881  recording stream. If it is T, *STANDARD-
881                      x2 (coordinate (+ x width))                      x2 (coordinate (+ x width))
882                      y2 (coordinate (+ y max-height)))))                      y2 (coordinate (+ y max-height)))))
883    
884  (defmethod* (setf output-record-position) :before (nx ny (record text-displayed-output-record))  (defmethod* (setf output-record-position) :before
885        (nx ny (record text-displayed-output-record-mixin))
886    (with-slots (x1 y1 x2 y2 x y start-x start-y end-x end-y) record    (with-slots (x1 y1 x2 y2 x y start-x start-y end-x end-y) record
887      (let ((dx (- nx x))      (let ((dx (- nx x))
888            (dy (- ny y)))            (dy (- ny y)))
# Line 802  recording stream. If it is T, *STANDARD- Line 891  recording stream. If it is T, *STANDARD-
891        (incf end-x dx)        (incf end-x dx)
892        (incf end-y dy))))        (incf end-y dy))))
893    
894  (defmethod add-character-output-to-text-record ((text-record text-displayed-output-record)  (defmethod add-character-output-to-text-record ((text-record text-displayed-output-record-mixin)
895                                                  character text-style char-width height                                                  character text-style char-width height
896                                                  new-baseline)                                                  new-baseline)
897    (with-slots (strings baseline width max-height start-y end-x end-y) text-record    (with-slots (strings baseline width max-height start-y end-x end-y) text-record
# Line 816  recording stream. If it is T, *STANDARD- Line 905  recording stream. If it is T, *STANDARD-
905            width (+ width char-width)))            width (+ width char-width)))
906    (tree-recompute-extent text-record))    (tree-recompute-extent text-record))
907    
908  (defmethod add-string-output-to-text-record ((text-record text-displayed-output-record)  (defmethod add-string-output-to-text-record ((text-record text-displayed-output-record-mixin)
909                                               string start end text-style string-width height                                               string start end text-style string-width height
910                                               new-baseline)                                               new-baseline)
911    (if end    (if end
# Line 845  recording stream. If it is T, *STANDARD- Line 934  recording stream. If it is T, *STANDARD-
934                width (+ width string-width)))                width (+ width string-width)))
935        (tree-recompute-extent text-record)))))        (tree-recompute-extent text-record)))))
936    
937  (defmethod replay-output-record ((record text-displayed-output-record) stream  (defmethod replay-output-record ((record text-displayed-output-record-mixin)
938                                     stream
939                                   &optional region (x-offset 0) (y-offset 0))                                   &optional region (x-offset 0) (y-offset 0))
940    (declare (ignore region))    (declare (ignore region))
941    (with-slots (strings baseline max-height start-x start-y wrapped    (with-slots (strings baseline max-height start-x start-y wrapped
# Line 882  recording stream. If it is T, *STANDARD- Line 972  recording stream. If it is T, *STANDARD-
972                                    :filled t)))                                    :filled t)))
973          (setf (%sheet-medium stream) old-medium))))) ;is sheet a sheet-with-medium-mixin? --GB          (setf (%sheet-medium stream) old-medium))))) ;is sheet a sheet-with-medium-mixin? --GB
974    
975  (defmethod output-record-start-cursor-position ((record text-displayed-output-record))  (defmethod output-record-start-cursor-position
976        ((record text-displayed-output-record-mixin))
977    (with-slots (start-x start-y) record    (with-slots (start-x start-y) record
978      (values start-x start-y)))      (values start-x start-y)))
979    
980  (defmethod output-record-end-cursor-position ((record text-displayed-output-record))  (defmethod output-record-end-cursor-position
981        ((record text-displayed-output-record-mixin))
982    (with-slots (end-x end-y) record    (with-slots (end-x end-y) record
983      (values end-x end-y)))      (values end-x end-y)))
984    
985  (defmethod text-displayed-output-record-string ((record text-displayed-output-record))  (defmethod text-displayed-output-record-string
986        ((record text-displayed-output-record-mixin))
987    (with-slots (strings) record    (with-slots (strings) record
988      (loop for result = ""      (loop for result = ""
989            for s in strings            for s in strings
# Line 898  recording stream. If it is T, *STANDARD- Line 991  recording stream. If it is T, *STANDARD-
991               finally (return result))))               finally (return result))))
992    
993    
994    (defclass stream-text-record (text-displayed-output-record-mixin)
995      ())
996    
997  ;;; Methods for text output to output recording streams  ;;; Methods for text output to output recording streams
998  (defmethod stream-text-output-record ((stream standard-output-recording-stream) text-style)  (defmethod stream-text-output-record ((stream standard-output-recording-stream) text-style)
999    (declare (ignore text-style))    (declare (ignore text-style))
1000    (let ((record (stream-current-text-output-record stream)))    (let ((record (stream-current-text-output-record stream)))
1001      (unless record      (unless record
1002        (setf (stream-current-text-output-record stream)        (setf (stream-current-text-output-record stream)
1003              (setq record (make-instance 'text-displayed-output-record)))              (setq record (make-instance 'stream-text-record)))
1004        (with-slots (start-x start-y end-x end-y x1 y1 x2 y2 x y        (with-slots (start-x start-y end-x end-y x1 y1 x2 y2 x y
1005                     initial-x1 initial-y1) record                     initial-x1 initial-y1) record
1006            (multiple-value-bind (cx cy) (stream-cursor-position stream)            (multiple-value-bind (cx cy) (stream-cursor-position stream)

Legend:
Removed from v.1.33  
changed lines
  Added in v.1.34

  ViewVC Help
Powered by ViewVC 1.1.5