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

Diff of /mcclim/recording.lisp

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

revision 1.6 by cvs, Mon Nov 6 23:50:29 2000 UTC revision 1.7 by cvs, Wed Nov 29 19:47:42 2000 UTC
# Line 72  Line 72 
72    nil)    nil)
73    
74  (defun replay (record stream &optional region)  (defun replay (record stream &optional region)
75    (let ((old-record-p (gensym)))    (let ((old-record-p (stream-recording-p stream))
76      `(let ((,old-record-p (stream-recording-p ,stream)))          (old-draw-p (stream-drawing-p stream)))
77         (when ,old-record-p      (when old-record-p
78           (unwind-protect        (unwind-protect
79               (progn            (progn
80                 (setf (stream-recording-p ,stream) nil)              (setf (stream-recording-p stream) nil
81                 (replay-output-record ,record ,stream ,region))                    (stream-drawing-p stream) t)
82             (setf (stream-recording-p ,stream) ,old-record-p))))))              (replay-output-record record stream region))
83            (setf (stream-recording-p stream) old-record-p
84                  (stream-drawing-p stream) old-draw-p)))))
85    
86  (defmethod replay-output-record ((record output-record) stream  (defmethod replay-output-record ((record output-record) stream
87                                   &optional region x-offset y-offset)                                   &optional region x-offset y-offset)
# Line 223  Line 225 
225    (with-output-recording-options (stream :record nil)    (with-output-recording-options (stream :record nil)
226      (call-next-method)))      (call-next-method)))
227    
228    (defmethod repaint-sheet ((stream stream-output-history-mixin) region)
229      (replay (stream-output-history stream) stream region))
230    
231    (defmethod handle-event ((stream stream-output-history-mixin) (event window-repaint-event))
232      (repaint-sheet stream nil))
233    
234    (defmethod handle-event ((stream stream-output-history-mixin) (event pointer-button-press-event))
235      (with-slots (button x y) event
236        (format *debug-io* "button ~D pressed at ~D,~D~%" button x y)))
237    
238    
239  ;;; standard-tree-output-history class  ;;; standard-tree-output-history class
240    
# Line 431  Line 443 
443                                                  character text-style width height                                                  character text-style width height
444                                                  new-baseline)                                                  new-baseline)
445    (with-slots (strings baseline max-height end-x end-y) text-record    (with-slots (strings baseline max-height end-x end-y) text-record
446      (setq baseline new-baseline      (if (and strings (eq (second (first (last strings))) text-style))
447            (vector-push-extend character (third (first (last strings))))
448          (setq strings (nconc strings (list (list end-x text-style (make-array 1 :initial-element character :element-type 'character :adjustable t :fill-pointer t))))))
449        (setq baseline (max baseline new-baseline)
450            end-x (+ end-x width)            end-x (+ end-x width)
451            end-y (max end-y new-baseline)            end-y (max end-y new-baseline)
452            max-height (max max-height height)            max-height (max max-height height)
453            )            )
     (if (and strings (eq (second (first (last strings))) text-style))  
         (vector-push-extend character (third (first (last strings))))  
       (setq strings (nconc strings (list (list end-x text-style (make-array 1 :initial-element character :element-type 'character :adjustable t :fill-pointer t))))))  
454        ))        ))
455    
456  (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)
457                                               string start end text-style width height                                               string start end text-style width height
458                                               new-baseline)                                               new-baseline)
459      (setq string (subseq string start end))
460    (with-slots (strings baseline max-height end-x) text-record    (with-slots (strings baseline max-height end-x) text-record
461      (setq baseline new-baseline      (setq baseline (max baseline new-baseline)
462            strings (nconc strings (list (list end-x text-style (subseq string start end))))            strings (nconc strings (list (list end-x text-style (make-array (length string) :initial-contents string :element-type 'character :adjustable t :fill-pointer t))))
463            end-x (+ end-x width)            end-x (+ end-x width)
464            max-height (max max-height height)            max-height (max max-height height)
465            )))            )))
# Line 455  Line 468 
468                                   &optional region x-offset y-offset)                                   &optional region x-offset y-offset)
469    (declare (ignore x-offset y-offset))    (declare (ignore x-offset y-offset))
470    (with-slots (strings baseline max-height start-x start-y) record    (with-slots (strings baseline max-height start-x start-y) record
471      (loop for y = start-y      (let ((old-medium (sheet-medium stream))
472            for (x text-style string) in strings            (new-medium (make-medium (port stream) stream)))
473            do (draw-text* stream string x y :text-style text-style :clipping-region region))))        (unwind-protect
474              (progn
475                (setf (sheet-medium stream) new-medium)
476                (setf (medium-sheet new-medium) stream)
477                (loop for y = (+ start-y baseline)
478                      for (x text-style string) in strings
479                      do (setf (medium-text-style new-medium) text-style)
480                         (draw-text* stream string x y
481                                     :text-style text-style :clipping-region region)))
482            (setf (sheet-medium stream) old-medium)))))
483    
484  (defmethod output-record-start-cursor-position ((record text-displayed-output-record))  (defmethod output-record-start-cursor-position ((record text-displayed-output-record))
485    (with-slots (start-x start-y) record    (with-slots (start-x start-y) record
# Line 502  Line 524 
524                (with-slots (start-x start-y end-x end-y) trec                (with-slots (start-x start-y end-x end-y) trec
525                  (multiple-value-bind (cx cy) (stream-cursor-position stream)                  (multiple-value-bind (cx cy) (stream-cursor-position stream)
526                    (setq start-x cx                    (setq start-x cx
527                          start-y cy                          start-y (+ cy (stream-vertical-spacing stream))
528                          end-x cx                          end-x cx
529                          end-y cy))))                          end-y cy))))
530            (add-character-output-to-text-record trec char            (add-character-output-to-text-record trec char
# Line 522  Line 544 
544              (with-slots (start-x start-y end-x end-y) trec              (with-slots (start-x start-y end-x end-y) trec
545                (multiple-value-bind (cx cy) (stream-cursor-position stream)                (multiple-value-bind (cx cy) (stream-cursor-position stream)
546                  (setq start-x cx                  (setq start-x cx
547                        start-y cy                        start-y (+ cy (stream-vertical-spacing stream))
548                        end-x cx                        end-x cx
549                        end-y cy))))                        end-y cy))))
550          (add-string-output-to-text-record trec string start end          (add-string-output-to-text-record trec string start end

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

  ViewVC Help
Powered by ViewVC 1.1.5