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

Diff of /mcclim/recording.lisp

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

revision 1.22 by adejneka, Mon Jul 30 05:44:26 2001 UTC revision 1.23 by rouanet, Mon Jul 30 14:08:41 2001 UTC
# Line 120  position of the upper-left corner of its Line 120  position of the upper-left corner of its
120  position is relative to the stream, where (0,0) is (initially) the  position is relative to the stream, where (0,0) is (initially) the
121  upper-left corner of the stream."))  upper-left corner of the stream."))
122    
123  ;(defgeneric* output-record-position (x y record))  (defgeneric* (setf output-record-position) (x y record))
124    
125  (declaim (ftype (function (output-record) (values integer integer))  (declaim (ftype (function (output-record) (values integer integer))
126                  output-record-start-cursor-position))                  output-record-start-cursor-position))
# Line 130  upper-left corner of the stream.")) Line 130  upper-left corner of the stream."))
130  positions are relative to the stream, where (0,0) is (initially) the  positions are relative to the stream, where (0,0) is (initially) the
131  upper-left corner of the stream."))  upper-left corner of the stream."))
132    
133  ;(defgeneric* output-record-start-cursor-position (x y record))  (defgeneric* (setf output-record-start-cursor-position) (x y record))
134    
135  (declaim (ftype (function (output-record) (values integer integer))  (declaim (ftype (function (output-record) (values integer integer))
136                  output-record-end-cursor-position))                  output-record-end-cursor-position))
# Line 140  upper-left corner of the stream.")) Line 140  upper-left corner of the stream."))
140  positions are relative to the stream, where (0,0) is (initially) the  positions are relative to the stream, where (0,0) is (initially) the
141  upper-left corner of the stream."))  upper-left corner of the stream."))
142    
143  ;(defgeneric* output-record-end-cursor-position (x y record))  (defgeneric* (setf output-record-end-cursor-position) (x y record))
144    
145  (defgeneric output-record-parent (record)  (defgeneric output-record-parent (record)
146    (:documentation    (:documentation
# Line 206  Only those records that overlap REGION a Line 206  Only those records that overlap REGION a
206    (with-slots (x y) record    (with-slots (x y) record
207      (values x y)))      (values x y)))
208    
209  (defmethod setf*-output-record-position (nx ny (record output-record-mixin))  (defmethod* (setf output-record-position) (nx ny (record output-record-mixin))
210    (with-slots (x y x1 y1 x2 y2) record    (with-slots (x y x1 y1 x2 y2) record
211      (let ((dx (- nx x))      (let ((dx (- nx x))
212            (dy (- ny y)))            (dy (- ny y)))
# Line 215  Only those records that overlap REGION a Line 215  Only those records that overlap REGION a
215      (setq x nx      (setq x nx
216            y ny)))            y ny)))
217    
218  (defmethod setf*-output-record-position :before (nx ny (record output-record))  (defmethod* (setf output-record-position) :before (nx ny (record output-record))
219    (multiple-value-bind (old-x old-y) (output-record-position record)    (multiple-value-bind (old-x old-y) (output-record-position record)
220      (loop with dx = (- nx old-x)      (loop with dx = (- nx old-x)
221            and dy = (- ny old-y)            and dy = (- ny old-y)
222            for child in (output-record-children record)            for child in (output-record-children record)
223            do (multiple-value-bind (x y) (output-record-position child)            do (multiple-value-bind (x y) (output-record-position child)
224                 (setf*-output-record-position (+ x dx) (+ y dy) child)))))                 (setf (output-record-position child) (values (+ x dx) (+ y dy)))))))
225    
226  (defmethod setf*-output-record-position :around (nx ny (record output-record-mixin))  (defmethod* (setf output-record-position) :around (nx ny (record output-record-mixin))
227    (declare (ignore nx ny))    (declare (ignore nx ny))
228    (with-bounding-rectangle* (min-x min-y max-x max-y) record    (with-bounding-rectangle* (min-x min-y max-x max-y) record
229      (call-next-method)      (call-next-method)
# Line 235  Only those records that overlap REGION a Line 235  Only those records that overlap REGION a
235  (defmethod output-record-start-cursor-position ((record displayed-output-record))  (defmethod output-record-start-cursor-position ((record displayed-output-record))
236    (values nil nil))    (values nil nil))
237    
238  (defmethod setf*-output-record-start-cursor-position (x y (record displayed-output-record))  (defmethod* (setf output-record-start-cursor-position) (x y (record displayed-output-record))
239    (declare (ignore x y))    (declare (ignore x y))
240    nil)    nil)
241    
242  (defmethod output-record-end-cursor-position ((record displayed-output-record))  (defmethod output-record-end-cursor-position ((record displayed-output-record))
243    (values nil nil))    (values nil nil))
244    
245  (defmethod setf*-output-record-end-cursor-position (x y (record displayed-output-record))  (defmethod* (setf output-record-end-cursor-position) (x y (record displayed-output-record))
246    (declare (ignore x y))    (declare (ignore x y))
247    nil)    nil)
248    
# Line 254  Only those records that overlap REGION a Line 254  Only those records that overlap REGION a
254          (unwind-protect          (unwind-protect
255               (letf (((stream-recording-p stream) nil))               (letf (((stream-recording-p stream) nil))
256                 (replay-output-record record stream region))                 (replay-output-record record stream region))
257            (setf*-stream-cursor-position cx cy stream))))))            (setf (stream-cursor-position stream) (values cx cy)))))))
258    
259  (defmethod replay-output-record ((record output-record) stream  (defmethod replay-output-record ((record output-record) stream
260                                   &optional region (x-offset 0) (y-offset 0))                                   &optional region (x-offset 0) (y-offset 0))
# Line 291  Only those records that overlap REGION a Line 291  Only those records that overlap REGION a
291    (    (
292     ))     ))
293    
294  (defmethod setf*-output-record-position (nx ny (record standard-sequence-output-record))  (defmethod* (setf output-record-position) (nx ny (record standard-sequence-output-record))
295    (with-slots (x y) record    (with-slots (x y) record
296                (setq x nx      (setq x nx
297                      y ny)))            y ny)))
298    
299  (defmethod output-record-children ((output-record output-record))  (defmethod output-record-children ((output-record output-record))
300    (with-slots (children) output-record    (with-slots (children) output-record
# Line 832  recording stream. If it is T, *STANDARD- Line 832  recording stream. If it is T, *STANDARD-
832                      x2 (coordinate (+ x width))                      x2 (coordinate (+ x width))
833                      y2 (coordinate (+ y max-height)))))                      y2 (coordinate (+ y max-height)))))
834    
835  (defmethod setf*-output-record-position :before (nx ny (record text-displayed-output-record))  (defmethod* (setf output-record-position) :before (nx ny (record text-displayed-output-record))
836    (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
837                (let ((dx (- nx x))      (let ((dx (- nx x))
838                      (dy (- ny y)))            (dy (- ny y)))
839                  (incf start-x dx)        (incf start-x dx)
840                  (incf start-y dy)        (incf start-y dy)
841                  (incf end-x dx)        (incf end-x dx)
842                  (incf end-y dy))))        (incf end-y dy))))
843    
844  (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)
845                                                  character text-style char-width height                                                  character text-style char-width height
# Line 887  recording stream. If it is T, *STANDARD- Line 887  recording stream. If it is T, *STANDARD-
887                      x-offset                      x-offset
888                      y-offset))                      y-offset))
889    
890               (setf*-stream-cursor-position start-x start-y stream)               (setf (stream-cursor-position stream) (values start-x start-y))
891               (letf (((slot-value stream 'baseline) baseline))               (letf (((slot-value stream 'baseline) baseline))
892                 (loop for (x text-style string) in strings                 (loop for (x text-style string) in strings
893                       do (setf (medium-text-style new-medium) text-style)                       do (setf (medium-text-style new-medium) text-style)
894                       (setf*-stream-cursor-position (+ x (- x1 initial-x1)) start-y stream)                       (setf (stream-cursor-position stream)
895                               (values (+ x (- x1 initial-x1)) start-y))
896                       (stream-write-line stream string)))                       (stream-write-line stream string)))
897               ;; clipping region               ;; clipping region
898               #|restore cursor position? set to (end-x,end-y)?|#               #|restore cursor position? set to (end-x,end-y)?|#
# Line 1032  recording stream. If it is T, *STANDARD- Line 1033  recording stream. If it is T, *STANDARD-
1033  (defmethod stream-terpri :after ((stream standard-output-recording-stream))  (defmethod stream-terpri :after ((stream standard-output-recording-stream))
1034    (stream-close-text-output-record stream))    (stream-close-text-output-record stream))
1035    
1036  (defmethod setf*-stream-cursor-position :after (x y (stream standard-output-recording-stream))  (defmethod* (setf stream-cursor-position) :after (x y (stream standard-output-recording-stream))
1037    (stream-close-text-output-record stream))    (stream-close-text-output-record stream))
1038    
1039  ;(defmethod stream-set-cursor-position :after ((stream standard-output-recording-stream))  ;(defmethod stream-set-cursor-position :after ((stream standard-output-recording-stream))

Legend:
Removed from v.1.22  
changed lines
  Added in v.1.23

  ViewVC Help
Powered by ViewVC 1.1.5