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

Diff of /mcclim/recording.lisp

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

revision 1.15 by adejneka, Sat Jul 21 05:17:48 2001 UTC revision 1.16 by adejneka, Sun Jul 22 07:52:33 2001 UTC
# Line 66  Line 66 
66    
67  (defmethod setf*-output-record-position (nx ny (record output-record-mixin))  (defmethod setf*-output-record-position (nx ny (record output-record-mixin))
68    (with-slots (x y) record    (with-slots (x y) record
69      (setq x nx                (setq x nx
70            y ny)))                      y ny)))
71    
72  (defmethod setf*-output-record-position :before (nx ny (record output-record))  (defmethod setf*-output-record-position :before (nx ny (record output-record))
73    (multiple-value-bind (old-x old-y) (output-record-position record)    (multiple-value-bind (old-x old-y) (output-record-position record)
# Line 81  Line 81 
81    (declare (ignore nx ny))    (declare (ignore nx ny))
82    (with-bounding-rectangle* (min-x min-y max-x max-y) record    (with-bounding-rectangle* (min-x min-y max-x max-y) record
83      (call-next-method)      (call-next-method)
84      (recompute-extent-for-changed-child (output-record-parent record) record      (let ((parent (output-record-parent record)))
85                                          min-x min-y max-x max-y)))        (when parent
86            (recompute-extent-for-changed-child parent record
87                                                min-x min-y max-x max-y)))))
88    
89  (defmethod output-record-start-cursor-position ((record displayed-output-record))  (defmethod output-record-start-cursor-position ((record displayed-output-record))
90    (values nil nil))    (values nil nil))
# Line 326  Line 328 
328    (setf (stream-current-output-record stream) (stream-output-history stream)))    (setf (stream-current-output-record stream) (stream-output-history stream)))
329    
330  (defmethod stream-add-output-record ((stream output-recording-stream) record)  (defmethod stream-add-output-record ((stream output-recording-stream) record)
331    (add-output-record record (stream-output-history stream)))    (add-output-record record (stream-current-output-record stream)))
332    
333  (defmethod stream-replay ((stream output-recording-stream) &optional region)  (defmethod stream-replay ((stream output-recording-stream) &optional region)
334    (replay (stream-output-history stream) stream region))    (replay (stream-output-history stream) stream region))
335    
336  (defmacro with-output-recording-options ((stream &key (record t) (draw t)) &body body)  (defmacro with-output-recording-options ((stream &key (record t) (draw t)) &body body)
337    (let ((old-record (gensym))    (declare (type symbol stream))
338          (old-draw (gensym)))    (when (eq stream 't)
339      `(with-slots (recording-p drawing-p) ,stream      (setq stream *standard-output*))
340         (let ((,old-record recording-p)    (let ((continuation-name (gensym)))
341               (,old-draw drawing-p))      `(let ((,continuation-name #'(lambda (,stream) ,@body)))
342           (unwind-protect         (invoke-with-output-recording-options ,stream
343               (progn                                               ,continuation-name
344                 (setq recording-p ,record                                               ,record
345                       drawing-p ,draw)                                               ,draw))))
346                 ,@body)  
347             (setq recording-p ,old-record  (defmethod invoke-with-output-recording-options
348                   drawing-p ,old-draw))))))    ((stream output-recording-stream) continuation record draw)
349      "Calls CONTINUATION on STREAM enabling or disabling recording and drawing
350    according to the flags RECORD and DRAW."
351      (with-slots (recording-p drawing-p) stream
352                  (let ((old-record recording-p)
353                        (old-draw drawing-p))
354                    (unwind-protect
355                        (progn
356                          (setq recording-p record
357                                drawing-p draw)
358                          (funcall continuation stream))
359                      (setq recording-p old-record
360                            drawing-p old-draw)))))
361    
362    (defmacro with-new-output-record ((stream
363                                       &optional
364                                       (record-type ''standard-sequence-output-record)
365                                       (record nil record-supplied-p)
366                                       &rest initargs)
367                                      &body body)
368      "Creates a new output record of type RECORD-TYPE and then captures
369    the output of BODY into the new output record, and inserts the new
370    record into the current \"open\" output record assotiated with STREAM.
371        If RECORD is supplied, it is the name of a variable that will be
372    lexically bound to the new output record inside the body. INITARGS are
373    CLOS initargs that are passed to MAKE-INSTANCE when the new output
374    record is created.
375        It returns the created output record.
376        The STREAM argument is a symbol that is bound to an output
377    recording stream. If it is T, *STANDARD-OUTPUT* is used."
378      (declare (type symbol stream record))
379      (when (eq stream 't)
380        (setq stream '*standard-output*))
381      (unless record-supplied-p
382        (setq record (gensym)))
383      `(invoke-with-new-output-record
384        ,stream
385        #'(lambda (,stream ,record)
386            ,(unless record-supplied-p `(declare (ignore ,record)))
387            ,@body)
388        ,record-type
389        ,@initargs))
390    
391    (defmethod invoke-with-new-output-record ((stream output-recording-stream)
392                                              continuation record-type
393                                              &rest initargs
394                                              &key parent)
395      (unless parent
396        (setq parent (stream-current-output-record stream)))
397      (let ((new-record (apply #'make-instance record-type :parent parent initargs))
398            (old-record (stream-current-output-record stream)))
399        (unwind-protect
400            (progn
401              (setf (stream-current-output-record stream) new-record)
402              (funcall continuation stream new-record))
403          (setf (stream-current-output-record stream) old-record)
404          (stream-add-output-record stream new-record))
405        new-record))
406    
407  (defmethod scroll-vertical :around ((stream output-recording-stream) dy)  (defmethod scroll-vertical :around ((stream output-recording-stream) dy)
408    (declare (ignore dy))    (declare (ignore dy))
# Line 421  Line 480 
480                       y1 (- tp ,border)                       y1 (- tp ,border)
481                       x2 (+ rt ,border)                       x2 (+ rt ,border)
482                       y2 (+ bt ,border))))))                       y2 (+ bt ,border))))))
483           (defmethod setf*-output-record-position :before (nx ny (record ,class-name))
484             (with-slots (x y x1 y1 x2 y2) record
485                         (let ((dx (- nx x))
486                               (dy (- ny y)))
487                           (incf x1 dx) (incf y1 dy)
488                           (incf x2 dx) (incf y2 dy))))
489         (defmethod ,method-name :around ((stream output-recording-stream) ,@args)         (defmethod ,method-name :around ((stream output-recording-stream) ,@args)
490           (with-sheet-medium (medium stream)           (with-sheet-medium (medium stream)
491             (when (stream-recording-p stream)             (when (stream-recording-p stream)
# Line 438  Line 503 
503         (defmethod replay-output-record ((record ,class-name) stream         (defmethod replay-output-record ((record ,class-name) stream
504                                          &optional (region +everywhere+) x-offset y-offset)                                          &optional (region +everywhere+) x-offset y-offset)
505           (declare (ignore x-offset y-offset))           (declare (ignore x-offset y-offset))
506           (with-slots (ink clip transform line-style text-style ,@args) record           (with-slots (x y ink clip transform line-style text-style ,@args) record
507             (let ((,old-medium (sheet-medium stream))                       (let ((transformation (compose-translation-with-transformation transform x y)))
508                   (,new-medium (make-merged-medium stream ink (region-intersection clip                         (let ((,old-medium (sheet-medium stream))
509                                                                  (untransform-region transform region))                               (,new-medium (make-merged-medium stream ink (region-intersection clip
510                                                    transform line-style text-style)))                                                                                                (untransform-region transformation region))
511               (finish-output *error-output*)                                                                transformation line-style text-style)))
512               (unwind-protect                           (finish-output *error-output*)
513                   (progn                           (unwind-protect
514                     (setf (sheet-medium stream) ,new-medium)                               (progn
515                     (setf (medium-sheet ,new-medium) stream)                                 (setf (sheet-medium stream) ,new-medium)
516                     (,method-name ,new-medium ,@args))                                 (setf (medium-sheet ,new-medium) stream)
517                 (setf (sheet-medium stream) ,old-medium))))))))                                 (,method-name ,new-medium ,@args))
518                               (setf (sheet-medium stream) ,old-medium)))))))))
519    
520  (def-grecording draw-point (point-x point-y)  (def-grecording draw-point (point-x point-y)
521    (with-transformed-position (transform point-x point-y)    (with-transformed-position (transform point-x point-y)
# Line 480  Line 546 
546             finally (return (values min-x min-y max-x max-y)))))             finally (return (values min-x min-y max-x max-y)))))
547    
548  (def-grecording draw-polygon (coord-seq closed filled)  (def-grecording draw-polygon (coord-seq closed filled)
549      ;; FIXME !!!
550      ;; If LINE-STYLE-JOINT-SHAPE is :MITTER, then the bb is larger than
551      ;; these numbers by (LINE-THICKNESS / (sin (angle / 2))),
552      ;; which is larger than LINE-THICKNESS
553    (with-transformed-positions (transform coord-seq)    (with-transformed-positions (transform coord-seq)
554       (loop for (x y) on coord-seq by #'cddr       (loop for (x y) on coord-seq by #'cddr
555             minimize x into min-x             minimize x into min-x
# Line 501  Line 571 
571    
572  (def-grecording draw-text (string point-x point-y start end  (def-grecording draw-text (string point-x point-y start end
573                             align-x align-y toward-x toward-y transform-glyphs)                             align-x align-y toward-x toward-y transform-glyphs)
574    ;; XXX transformation!!!    ;; FIXME!!! transformation
575   (let* ((width (stream-string-width stream string   (let* ((width (stream-string-width stream string
576                                      :start start :end end                                      :start start :end end
577                                      :text-style text-style))                                      :text-style text-style))

Legend:
Removed from v.1.15  
changed lines
  Added in v.1.16

  ViewVC Help
Powered by ViewVC 1.1.5