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

Diff of /mcclim/recording.lisp

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

revision 1.5 by cvs, Thu Nov 2 00:12:13 2000 UTC revision 1.6 by cvs, Mon Nov 6 23:50:29 2000 UTC
# Line 418  Line 418 
418    ((strings :initform nil)    ((strings :initform nil)
419     (baseline :initform 0)     (baseline :initform 0)
420     (max-height :initform 0)     (max-height :initform 0)
421     (start-x :initarg :start-x     (start-x :initarg :start-x)
422              :initform 0)     (start-y :initarg :start-y)
    (start-y :initarg :start-y  
             :initform 0)  
423     (end-x)     (end-x)
424     (end-y)))     (end-y)))
425    
 (defmethod initialize-instance :after ((record text-displayed-output-record) &rest args)  
   (declare (ignore args))  
   (with-slots (start-x start-y end-x end-y) record  
     (setq end-x start-x  
           end-y start-y)))  
   
426  (defun text-displayed-output-record-p (x)  (defun text-displayed-output-record-p (x)
427    (typep x 'text-displayed-output-record))    (typep x 'text-displayed-output-record))
428    
# Line 438  Line 430 
430  (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)
431                                                  character text-style width height                                                  character text-style width height
432                                                  new-baseline)                                                  new-baseline)
433    (with-slots (strings baseline max-height end-x) text-record    (with-slots (strings baseline max-height end-x end-y) text-record
434      (setq baseline new-baseline      (setq baseline new-baseline
           strings (nconc strings (list (list end-x text-style (make-string 1 :initial-element character))))  
435            end-x (+ end-x width)            end-x (+ end-x width)
436              end-y (max end-y new-baseline)
437            max-height (max max-height height)            max-height (max max-height height)
438            )))            )
439        (if (and strings (eq (second (first (last strings))) text-style))
440            (vector-push-extend character (third (first (last strings))))
441          (setq strings (nconc strings (list (list end-x text-style (make-array 1 :initial-element character :element-type 'character :adjustable t :fill-pointer t))))))
442          ))
443    
444  (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)
445                                               string start end text-style width height                                               string start end text-style width height
# Line 484  Line 480 
480    (let ((trec (stream-current-output-record stream)))    (let ((trec (stream-current-output-record stream)))
481      (unless (text-displayed-output-record-p trec)      (unless (text-displayed-output-record-p trec)
482        (setq trec (make-instance 'text-displayed-output-record))        (setq trec (make-instance 'text-displayed-output-record))
483        (add-output-record trec (stream-current-output-record stream))        (add-output-record trec (stream-output-history stream))
484        (setf (stream-current-output-record stream) trec))        (setf (stream-current-output-record stream) trec))
485      trec))      trec))
486    
487  (defmethod stream-write-char :around ((stream output-recording-stream) char)  (defmethod stream-write-char :around ((stream output-recording-stream) char)
488    (when (stream-recording-p stream)    (when (stream-recording-p stream)
489      (let ((medium (sheet-medium stream))      (cond
490            (trec (get-text-record stream)))       ((or (eql char #\return)
491        (multiple-value-bind (width height ignore1 ignore2 baseline)            (eql char #\newline))
492            (text-size medium (string char))        (let ((trec (make-instance 'text-displayed-output-record)))
493          (declare (ignore ignore1 ignore2))          (add-output-record trec (stream-output-history stream))
494          (add-character-output-to-text-record trec char          (setf (stream-current-output-record stream) trec)))
495                                               (medium-text-style medium)       (t
496                                               width height baseline))))        (let ((medium (sheet-medium stream))
497                (trec (get-text-record stream)))
498              (multiple-value-bind (width height ignore1 ignore2 baseline)
499                  (text-size medium (string char))
500              (declare (ignore ignore1 ignore2))
501              (if (not (slot-boundp trec 'start-y))
502                  (with-slots (start-x start-y end-x end-y) trec
503                    (multiple-value-bind (cx cy) (stream-cursor-position stream)
504                      (setq start-x cx
505                            start-y cy
506                            end-x cx
507                            end-y cy))))
508              (add-character-output-to-text-record trec char
509                                                   (medium-text-style medium)
510                                                   width height baseline))))))
511    (call-next-method))    (call-next-method))
512    
513  (defmethod stream-write-string :around ((stream output-recording-stream) string  (defmethod stream-write-string :around ((stream output-recording-stream) string
# Line 508  Line 518 
518        (multiple-value-bind (width height ignore1 ignore2 baseline)        (multiple-value-bind (width height ignore1 ignore2 baseline)
519            (text-size medium string)            (text-size medium string)
520          (declare (ignore ignore1 ignore2))          (declare (ignore ignore1 ignore2))
521            (if (not (slot-boundp trec 'start-y))
522                (with-slots (start-x start-y end-x end-y) trec
523                  (multiple-value-bind (cx cy) (stream-cursor-position stream)
524                    (setq start-x cx
525                          start-y cy
526                          end-x cx
527                          end-y cy))))
528          (add-string-output-to-text-record trec string start end          (add-string-output-to-text-record trec string start end
529                                            (medium-text-style medium)                                            (medium-text-style medium)
530                                            width height baseline))))                                            width height baseline))))

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

  ViewVC Help
Powered by ViewVC 1.1.5