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

Diff of /mcclim/recording.lisp

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

revision 1.8 by cvs, Fri Dec 1 00:31:28 2000 UTC revision 1.9 by cvs, Sat Dec 2 07:56:07 2000 UTC
# Line 157  Line 157 
157  (defmethod recompute-extent-for-changed-child ((record output-record) child  (defmethod recompute-extent-for-changed-child ((record output-record) child
158                                                 old-min-x old-min-y old-max-x old-max-y)                                                 old-min-x old-min-y old-max-x old-max-y)
159    (declare (ignore child old-min-x old-min-y old-max-x old-max-y))    (declare (ignore child old-min-x old-min-y old-max-x old-max-y))
160    (error "I don't understand RECOMPUTE-EXTENT-FOR-CHANGED-CHILD - mikemac"))    (tree-recompute-extent record))
161    
162  (defmethod tree-recompute-extent ((record output-record))  (defmethod tree-recompute-extent ((record output-record))
163    (with-slots (parent children x1 y1 x2 y2) record    (with-slots (parent children x1 y1 x2 y2) record
# Line 446  Line 446 
446            (format stream "~D,~D ~S" start-x start-y (mapcar #'third strings)))            (format stream "~D,~D ~S" start-x start-y (mapcar #'third strings)))
447        (format stream "empty"))))        (format stream "empty"))))
448    
449    (defmethod tree-recompute-extent ((text-record text-displayed-output-record))
450      (with-slots (parent start-x start-y end-x end-y x1 y1 x2 y2) text-record
451        (setq x1 start-x
452              x2 end-x
453              y1 start-y
454              y2 end-y)
455        (recompute-extent-for-changed-child parent text-record start-x start-y end-x end-y)))
456    
457  (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)
458                                                  character text-style width height                                                  character text-style width height
459                                                  new-baseline)                                                  new-baseline)
460    (with-slots (strings baseline max-height end-x end-y) text-record    (with-slots (strings baseline max-height start-y end-x end-y) text-record
461      (if (and strings (eq (second (first (last strings))) text-style))      (if (and strings (eq (second (first (last strings))) text-style))
462          (vector-push-extend character (third (first (last strings))))          (vector-push-extend character (third (first (last strings))))
463        (setq strings (nconc strings (list (list end-x text-style (make-array 1 :initial-element character :element-type 'character :adjustable t :fill-pointer t))))))        (setq strings (nconc strings (list (list end-x text-style (make-array 1 :initial-element character :element-type 'character :adjustable t :fill-pointer t))))))
464      (setq baseline (max baseline new-baseline)      (setq baseline (max baseline new-baseline)
465            end-x (+ end-x width)            end-x (+ end-x width)
           end-y (max end-y new-baseline)  
466            max-height (max max-height height)            max-height (max max-height height)
467              end-y (max end-y (+ start-y max-height))
468            )            )
469        ))        )
470      (tree-recompute-extent text-record))
471    
472  (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)
473                                               string start end text-style width height                                               string start end text-style width height
# Line 516  Line 525 
525        (setq trec (make-instance 'text-displayed-output-record))        (setq trec (make-instance 'text-displayed-output-record))
526        (add-output-record trec (stream-output-history stream))        (add-output-record trec (stream-output-history stream))
527        (setf (stream-current-output-record stream) trec)        (setf (stream-current-output-record stream) trec)
528        (with-slots (start-x start-y end-x end-y) trec        (with-slots (start-x start-y end-x end-y x1 y1 x2 y2) trec
529            (multiple-value-bind (cx cy) (stream-cursor-position stream)            (multiple-value-bind (cx cy) (stream-cursor-position stream)
530              (setq start-x cx              (setq start-x cx
531                    start-y (+ cy (stream-vertical-spacing stream))                    start-y (+ cy (stream-vertical-spacing stream))
532                    end-x start-x                    end-x start-x
533                    end-y start-y))))                    end-y start-y
534                      x1 start-x
535                      x2 end-x
536                      y1 start-y
537                      y2 end-y))))
538      trec))      trec))
539    
540  (defmethod stream-write-char :around ((stream output-recording-stream) char)  (defmethod stream-write-char :around ((stream output-recording-stream) char)
# Line 545  Line 558 
558        (let ((trec (make-instance 'text-displayed-output-record)))        (let ((trec (make-instance 'text-displayed-output-record)))
559          (add-output-record trec (stream-output-history stream))          (add-output-record trec (stream-output-history stream))
560          (setf (stream-current-output-record stream) trec)          (setf (stream-current-output-record stream) trec)
561          (with-slots (start-x start-y end-x end-y) trec          (with-slots (start-x start-y end-x end-y x1 y1 x2 y2) trec
562            (multiple-value-bind (cx cy) (stream-cursor-position stream)            (multiple-value-bind (cx cy) (stream-cursor-position stream)
563              (setq start-x cx              (setq start-x cx
564                    start-y (+ cy (stream-vertical-spacing stream))                    start-y (+ cy (stream-vertical-spacing stream))
565                    end-x start-x                    end-x start-x
566                    end-y start-y))))))))                    end-y start-y
567                      x1 start-x
568                      x2 end-x
569                      y1 start-y
570                      y2 end-y))))))))
571    
572  (defmethod stream-wrap-line :before ((stream output-recording-stream))  (defmethod stream-wrap-line :before ((stream output-recording-stream))
573    (when (stream-recording-p stream)    (when (stream-recording-p stream)

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

  ViewVC Help
Powered by ViewVC 1.1.5