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

Diff of /mcclim/recording.lisp

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

revision 1.7 by cvs, Wed Nov 29 19:47:42 2000 UTC revision 1.8 by cvs, Fri Dec 1 00:31:28 2000 UTC
# Line 74  Line 74 
74  (defun replay (record stream &optional region)  (defun replay (record stream &optional region)
75    (let ((old-record-p (stream-recording-p stream))    (let ((old-record-p (stream-recording-p stream))
76          (old-draw-p (stream-drawing-p stream)))          (old-draw-p (stream-drawing-p stream)))
77      (when old-record-p      (unwind-protect
78        (unwind-protect          (progn
79            (progn            (setf (stream-recording-p stream) nil
80              (setf (stream-recording-p stream) nil                  (stream-drawing-p stream) t)
81                    (stream-drawing-p stream) t)            (replay-output-record record stream region))
82              (replay-output-record record stream region))        (setf (stream-recording-p stream) old-record-p
83          (setf (stream-recording-p stream) old-record-p              (stream-drawing-p stream) old-draw-p))))
               (stream-drawing-p stream) old-draw-p)))))  
84    
85  (defmethod replay-output-record ((record output-record) stream  (defmethod replay-output-record ((record output-record) stream
86                                   &optional region x-offset y-offset)                                   &optional region x-offset y-offset)
# Line 433  Line 432 
432     (start-x :initarg :start-x)     (start-x :initarg :start-x)
433     (start-y :initarg :start-y)     (start-y :initarg :start-y)
434     (end-x)     (end-x)
435     (end-y)))     (end-y)
436       (wrapped :initform nil
437                :accessor text-record-wrapped)))
438    
439  (defun text-displayed-output-record-p (x)  (defun text-displayed-output-record-p (x)
440    (typep x 'text-displayed-output-record))    (typep x 'text-displayed-output-record))
441    
442    (defmethod print-object ((self text-displayed-output-record) stream)
443      (print-unreadable-object (self stream :type t :identity t)
444        (if (slot-boundp self 'start-x)
445            (with-slots (start-x start-y strings) self
446              (format stream "~D,~D ~S" start-x start-y (mapcar #'third strings)))
447          (format stream "empty"))))
448    
449  (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)
450                                                  character text-style width height                                                  character text-style width height
# Line 467  Line 474 
474  (defmethod replay-output-record ((record text-displayed-output-record) stream  (defmethod replay-output-record ((record text-displayed-output-record) stream
475                                   &optional region x-offset y-offset)                                   &optional region x-offset y-offset)
476    (declare (ignore x-offset y-offset))    (declare (ignore x-offset y-offset))
477    (with-slots (strings baseline max-height start-x start-y) record    (with-slots (strings baseline max-height start-x start-y wrapped) record
478      (let ((old-medium (sheet-medium stream))      (let ((old-medium (sheet-medium stream))
479            (new-medium (make-medium (port stream) stream)))            (new-medium (make-medium (port stream) stream)))
480        (unwind-protect        (unwind-protect
# Line 478  Line 485 
485                    for (x text-style string) in strings                    for (x text-style string) in strings
486                    do (setf (medium-text-style new-medium) text-style)                    do (setf (medium-text-style new-medium) text-style)
487                       (draw-text* stream string x y                       (draw-text* stream string x y
488                                   :text-style text-style :clipping-region region)))                                   :text-style text-style :clipping-region region))
489                (if wrapped
490                    (draw-rectangle* (sheet-medium stream)
491                                     (+ wrapped 0) start-y (+ wrapped 4) (+ start-y max-height)
492                                     :ink +foreground-ink+
493                                     :filled t)))
494          (setf (sheet-medium stream) old-medium)))))          (setf (sheet-medium stream) old-medium)))))
495    
496  (defmethod output-record-start-cursor-position ((record text-displayed-output-record))  (defmethod output-record-start-cursor-position ((record text-displayed-output-record))
# Line 503  Line 515 
515      (unless (text-displayed-output-record-p trec)      (unless (text-displayed-output-record-p trec)
516        (setq trec (make-instance 'text-displayed-output-record))        (setq trec (make-instance 'text-displayed-output-record))
517        (add-output-record trec (stream-output-history stream))        (add-output-record trec (stream-output-history stream))
518        (setf (stream-current-output-record stream) trec))        (setf (stream-current-output-record stream) trec)
519          (with-slots (start-x start-y end-x end-y) trec
520              (multiple-value-bind (cx cy) (stream-cursor-position stream)
521                (setq start-x cx
522                      start-y (+ cy (stream-vertical-spacing stream))
523                      end-x start-x
524                      end-y start-y))))
525      trec))      trec))
526    
527  (defmethod stream-write-char :around ((stream output-recording-stream) char)  (defmethod stream-write-char :around ((stream output-recording-stream) char)
528    (when (stream-recording-p stream)    (when (stream-recording-p stream)
529        (get-text-record stream))
530      (call-next-method)
531      (when (stream-recording-p stream)
532      (cond      (cond
533       ((or (eql char #\return)       ((not (or (eql char #\return)
534            (eql char #\newline))                 (eql char #\newline)))
535          (let* ((medium (sheet-medium stream))
536                 (text-style (medium-text-style medium))
537                 (trec (get-text-record stream))
538                 (port (port stream)))
539            (add-character-output-to-text-record
540             trec char text-style
541             (stream-character-width stream char :text-style text-style)
542             (text-style-height text-style port)
543             (text-style-ascent text-style port))))
544         (t
545        (let ((trec (make-instance 'text-displayed-output-record)))        (let ((trec (make-instance 'text-displayed-output-record)))
546          (add-output-record trec (stream-output-history stream))          (add-output-record trec (stream-output-history stream))
547          (setf (stream-current-output-record stream) trec)))          (setf (stream-current-output-record stream) trec)
548       (t          (with-slots (start-x start-y end-x end-y) trec
549        (let ((medium (sheet-medium stream))            (multiple-value-bind (cx cy) (stream-cursor-position stream)
550              (trec (get-text-record stream)))              (setq start-x cx
551            (multiple-value-bind (width height ignore1 ignore2 baseline)                    start-y (+ cy (stream-vertical-spacing stream))
552                (text-size medium (string char))                    end-x start-x
553            (declare (ignore ignore1 ignore2))                    end-y start-y))))))))
           (if (not (slot-boundp trec 'start-y))  
               (with-slots (start-x start-y end-x end-y) trec  
                 (multiple-value-bind (cx cy) (stream-cursor-position stream)  
                   (setq start-x cx  
                         start-y (+ cy (stream-vertical-spacing stream))  
                         end-x cx  
                         end-y cy))))  
           (add-character-output-to-text-record trec char  
                                                (medium-text-style medium)  
                                                width height baseline))))))  
   (call-next-method))  
554    
555  (defmethod stream-write-string :around ((stream output-recording-stream) string  (defmethod stream-wrap-line :before ((stream output-recording-stream))
                                         &optional (start 0) end)  
556    (when (stream-recording-p stream)    (when (stream-recording-p stream)
     (let ((medium (sheet-medium stream))  
           (trec (get-text-record stream)))  
       (multiple-value-bind (width height ignore1 ignore2 baseline)  
           (text-size medium string)  
         (declare (ignore ignore1 ignore2))  
         (if (not (slot-boundp trec 'start-y))  
             (with-slots (start-x start-y end-x end-y) trec  
               (multiple-value-bind (cx cy) (stream-cursor-position stream)  
                 (setq start-x cx  
                       start-y (+ cy (stream-vertical-spacing stream))  
                       end-x cx  
                       end-y cy))))  
         (add-string-output-to-text-record trec string start end  
                                           (medium-text-style medium)  
                                           width height baseline))))  
   (call-next-method))  
557        (setf (text-record-wrapped (get-text-record stream)) (stream-text-margin stream))))

Legend:
Removed from v.1.7  
changed lines
  Added in v.1.8

  ViewVC Help
Powered by ViewVC 1.1.5