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

Diff of /mcclim/recording.lisp

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

revision 1.21 by adejneka, Sat Jul 28 09:03:37 2001 UTC revision 1.22 by adejneka, Mon Jul 30 05:44:26 2001 UTC
# Line 26  Line 26 
26  ;;; TODO:  ;;; TODO:
27  ;;; - Scrolling does not work correctly. Region is given in "window" coordinates,  ;;; - Scrolling does not work correctly. Region is given in "window" coordinates,
28  ;;;   without bounding-rectangle-position transformation.  ;;;   without bounding-rectangle-position transformation.
 ;;; - Wrapping  
 ;;; - Text recording should check for DRAWING-P and block output if necessary  
29  ;;; - Redo setf*-output-record-position, extent recomputation for  ;;; - Redo setf*-output-record-position, extent recomputation for
30  ;;;   compound records  ;;;   compound records
31  ;;; - How to deal with mixing of positioning/modifying?  ;;; - How to deal with mixing of positioning/modifying?
32    ;;; - When DRAWING-P is NIL, should stream cursor move?
33    ;;; - OUTPUT-RECORD is a protocol class, it should not have any slots/methods.
34    
35    ;;; A useful macro. It should be in some other place.
36    (in-package :CLIM-INTERNALS)
37    (defun check-letf-form (form)
38      (assert (and (listp form)
39                   (= 2 (length form)))))
40    
41    (shadow 'letf)
42    (defmacro letf ((&rest forms) &body body &environment env)
43      "LETF ({(Place Value)}*) Declaration* Form* During evaluation of the
44    Forms, SETF the Places to the result of evaluating the Value forms.
45    The places are SETF-ed in parallel after all of the Values are
46    evaluated."
47      (mapc #'check-letf-form forms)
48      (let* (init-let-form save-old-values-let-form
49             new-values-set-form old-values-set-form
50             update-form)
51        (loop for (place new-value) in forms
52              for (vars vals store-vars writer-form reader-form)
53                  = (multiple-value-list (get-setf-expansion place env))
54              for (store-var) = store-vars
55              for old-value-name = (gensym)
56              nconc (mapcar #'list vars vals) into temp-init-let-form
57              collect (list old-value-name reader-form) into temp-save-old-values-let-form
58              nconc (list store-var new-value) into temp-new-values-set-form
59              nconc (list store-var old-value-name) into temp-old-values-set-form
60              collect writer-form into temp-update-form
61              finally (setq init-let-form temp-init-let-form
62                            save-old-values-let-form temp-save-old-values-let-form
63                            new-values-set-form temp-new-values-set-form
64                            old-values-set-form temp-old-values-set-form
65                            update-form (cons 'progn temp-update-form)))
66        `(let* ,init-let-form
67           (let ,save-old-values-let-form
68             (unwind-protect
69                 (progn (setq ,@new-values-set-form)
70                        ,update-form
71                        (progn ,@body))
72               (setq ,@old-values-set-form)
73               ,update-form)))))
74    ;;; ---
75    
76  (in-package :CLIM-INTERNALS)  (in-package :CLIM-INTERNALS)
77    
78  (defclass output-record-mixin ()  (defclass output-record-mixin ()
79    ((x :initarg :x-position    ((x :initarg :x-position
80        :initform 0)        :initform 0
81          :type rational)
82     (y :initarg :y-position     (y :initarg :y-position
83        :initform 0)        :initform 0
84          :type rational)
85     (parent :initarg :parent     (parent :initarg :parent
86             :initform nil             :initform nil
87             :reader output-record-parent)))             :reader output-record-parent)))
# Line 68  Line 111 
111    (typep x 'displayed-output-record))    (typep x 'displayed-output-record))
112    
113  ; 16.2.1. The Basic Output Record Protocol  ; 16.2.1. The Basic Output Record Protocol
114  (defgeneric output-record-position (record))  (declaim (ftype (function (output-record) (values rational rational))
115                    output-record-position))
116    (defgeneric output-record-position (record)
117      (:documentation
118       "Returns the x and y position of RECORD. The position is the
119    position of the upper-left corner of its bounding rectangle. The
120    position is relative to the stream, where (0,0) is (initially) the
121    upper-left corner of the stream."))
122    
123  ;(defgeneric* output-record-position (x y record))  ;(defgeneric* output-record-position (x y record))
124  (defgeneric output-record-start-cursor-position (record))  
125    (declaim (ftype (function (output-record) (values integer integer))
126                    output-record-start-cursor-position))
127    (defgeneric output-record-start-cursor-position (record)
128      (:documentation
129       "Returns the x and y starting cursor position of RECORD. The
130    positions are relative to the stream, where (0,0) is (initially) the
131    upper-left corner of the stream."))
132    
133  ;(defgeneric* output-record-start-cursor-position (x y record))  ;(defgeneric* output-record-start-cursor-position (x y record))
134  (defgeneric output-record-end-cursor-position (record))  
135    (declaim (ftype (function (output-record) (values integer integer))
136                    output-record-end-cursor-position))
137    (defgeneric output-record-end-cursor-position (record)
138      (:documentation
139       "Returns the x and y ending cursor position of RECORD. The
140    positions are relative to the stream, where (0,0) is (initially) the
141    upper-left corner of the stream."))
142    
143  ;(defgeneric* output-record-end-cursor-position (x y record))  ;(defgeneric* output-record-end-cursor-position (x y record))
144  (defgeneric output-record-parent (record))  
145  ;(defgeneric replay (record stream &optional region))  (defgeneric output-record-parent (record)
146      (:documentation
147       "Returns the output record that is the parent of RECORD, or nil if
148    RECORD has no parent."))
149    
150    (defgeneric replay (record stream &optional region)
151      (:documentation ""))
152    
153  (defgeneric replay-output-record (record stream  (defgeneric replay-output-record (record stream
154                                    &optional region x-offset y-offset))                                    &optional region x-offset y-offset)
155      (:documentation "Displays the output captured by RECORD on the
156    STREAM, exactly as it was originally captured. The current user
157    transformation, line style, text style, ink and clipping region of
158    STREAM are all ignored. Instead, these are gotten from the output
159    record.
160    
161    Only those records that overlap REGION are displayed."))
162    
163  (defgeneric output-record-hit-detection-rectangle* (record))  (defgeneric output-record-hit-detection-rectangle* (record))
164    
165  (defgeneric output-record-refined-position-test (record x y))  (defgeneric output-record-refined-position-test (record x y))
166    
167  (defgeneric highlight-output-record (record stream state))  (defgeneric highlight-output-record (record stream state))
168    
169  (defgeneric displayed-output-record-ink (displayed-output-record))  (defgeneric displayed-output-record-ink (displayed-output-record))
170    
171  ; 16.2.2. Output Record "Database" Protocol  ; 16.2.2. Output Record "Database" Protocol
172    
173  (defgeneric output-record-children (record))  (defgeneric output-record-children (record))
174    
175  (defgeneric add-output-record (child record))  (defgeneric add-output-record (child record))
176    
177  (defgeneric delete-output-record (child record &optional (errorp t)))  (defgeneric delete-output-record (child record &optional (errorp t)))
178    
179  (defgeneric clear-output-record (record))  (defgeneric clear-output-record (record))
180    
181  (defgeneric output-record-count (record))  (defgeneric output-record-count (record))
182    
183  (defgeneric map-over-output-records-containing-position  (defgeneric map-over-output-records-containing-position
184    (function record x y &optional x-offset y-offset &rest function-args))    (function record x y &optional x-offset y-offset &rest function-args))
185    
186  (defgeneric map-over-output-records-overlapping-region  (defgeneric map-over-output-records-overlapping-region
187    (function record region &optional x-offset y-offset &rest function-args))    (function record region &optional x-offset y-offset &rest function-args))
188    
189  ; 16.2.3. Output Record Change Notification Protocol  ; 16.2.3. Output Record Change Notification Protocol
190    
191  (defgeneric recompute-extent-for-new-child (record child))  (defgeneric recompute-extent-for-new-child (record child))
192    
193  (defgeneric recompute-extent-for-changed-child  (defgeneric recompute-extent-for-changed-child
194    (record child old-min-x old-min-y old-max-x old-max-y))    (record child old-min-x old-min-y old-max-x old-max-y))
195    
196  (defgeneric tree-recompute-extent (record))  (defgeneric tree-recompute-extent (record))
197    
198  ;;; Methods  ;;; Methods
199    
200  (defmethod initialize-instance :after ((record output-record) &rest args  (defmethod initialize-instance :after ((record output-record) &rest args
201                                         &key size                                         &key size
202                                         &allow-other-keys)                                         &allow-other-keys)
# Line 150  Line 246 
246    (declare (ignore x y))    (declare (ignore x y))
247    nil)    nil)
248    
249  (defun replay (record stream &optional region)  (defmethod replay (record stream &optional region)
250    (stream-close-text-output-record stream)    (stream-close-text-output-record stream)
251    (when (stream-drawing-p stream)    (when (stream-drawing-p stream)
252      (let ((old-record-p (stream-recording-p stream)))      (with-cursor-off stream
253        (unwind-protect        (multiple-value-bind (cx cy) (stream-cursor-position stream)
254             (progn          (unwind-protect
255               (setf (stream-recording-p stream) nil)               (letf (((stream-recording-p stream) nil))
256               (replay-output-record record stream region))                 (replay-output-record record stream region))
257          (setf (stream-recording-p stream) old-record-p)))))            (setf*-stream-cursor-position cx cy stream))))))
258    
259  (defmethod replay-output-record ((record output-record) stream  (defmethod replay-output-record ((record output-record) stream
260                                   &optional region (x-offset 0) (y-offset 0))                                   &optional region (x-offset 0) (y-offset 0))
# Line 315  Line 411 
411                    y2 bottom))))))                    y2 bottom))))))
412    
413  (defmethod tree-recompute-extent ((record output-record))  (defmethod tree-recompute-extent ((record output-record))
414    (with-slots (parent children x1 y1 x2 y2) record    (with-slots (children x1 y1 x2 y2) record
415      (if (null children)      (if (null children)
416          (setq x1 (coordinate 0)          (setq x1 (coordinate 0)
417                y1 (coordinate 0)                y1 (coordinate 0)
# Line 331  Line 427 
427          (setq x1 left          (setq x1 left
428                y1 top                y1 top
429                x2 right                x2 right
430                y2 bottom)))                y2 bottom)))))
431      (if parent  
432          (recompute-extent-for-changed-child parent record x1 y1 x2 y2))))  (defmethod tree-recompute-extent :around ((record output-record))
433      (let ((old-rectangle (multiple-value-call #'make-bounding-rectangle
434                             (bounding-rectangle* record))))
435        (call-next-method)
436        (with-slots (parent x1 y1 x2 y2) record
437                    (when (and parent (not (region-equal old-rectangle record)))
438                      (recompute-extent-for-changed-child parent record x1 y1 x2 y2)))))
439    
440    
441  ;;; Graphics recording classes  ;;; Graphics recording classes
# Line 383  Line 485 
485    
486  ;;; 16.4.1 The Output Recording Stream Protocol  ;;; 16.4.1 The Output Recording Stream Protocol
487  (defgeneric stream-recording-p (stream))  (defgeneric stream-recording-p (stream))
488    
489  (defgeneric (setf stream-recording-p) (recording-p stream))  (defgeneric (setf stream-recording-p) (recording-p stream))
490    
491  (defgeneric stream-drawing-p (stream))  (defgeneric stream-drawing-p (stream))
492    
493  (defgeneric (setf stream-drawing-p) (drawing-p stream))  (defgeneric (setf stream-drawing-p) (drawing-p stream))
494    
495  (defgeneric stream-output-history (stream))  (defgeneric stream-output-history (stream))
496    
497  (defgeneric stream-current-output-record (stream))  (defgeneric stream-current-output-record (stream))
498    
499  (defgeneric (setf stream-current-output-record) (record stream))  (defgeneric (setf stream-current-output-record) (record stream))
500    
501  (defgeneric stream-add-output-record (stream record))  (defgeneric stream-add-output-record (stream record))
502    
503  (defgeneric stream-replay (stream &optional region))  (defgeneric stream-replay (stream &optional region))
504    
505  (defgeneric erase-output-record (record stream &optional (errorp t)))  (defgeneric erase-output-record (record stream &optional (errorp t)))
506    
507  (defgeneric copy-textual-output-history (window stream &optional region record))  (defgeneric copy-textual-output-history (window stream &optional region record))
508    
509  ;;; 16.4.3 Text Output Recording  ;;; 16.4.3 Text Output Recording
510    
511  (defgeneric stream-text-output-record (stream text-style))  (defgeneric stream-text-output-record (stream text-style))
512    
513  (defgeneric stream-close-text-output-record (stream))  (defgeneric stream-close-text-output-record (stream))
514    
515  (defgeneric stream-add-character-output  (defgeneric stream-add-character-output
516    (stream character text-style width height baseline))    (stream character text-style width height baseline))
517    
518  (defgeneric stream-add-string-output  (defgeneric stream-add-string-output
519    (stream string start end text-style width height baseline))    (stream string start end text-style width height baseline))
520    
# Line 430  Line 546 
546  according to the flags RECORD and DRAW."  according to the flags RECORD and DRAW."
547    (declare (dynamic-extent continuation))    (declare (dynamic-extent continuation))
548    (with-slots (recording-p drawing-p) stream    (with-slots (recording-p drawing-p) stream
549      (let ((old-record recording-p)                (unless (eq recording-p record)
550            (old-draw drawing-p))                  (stream-close-text-output-record stream))
551        (unless (eq old-record record)                (letf ((recording-p record)
552          (stream-close-text-output-record stream))                       (drawing-p draw))
553        (unwind-protect                  (funcall continuation stream))))
            (progn  
              (setq recording-p record  
                    drawing-p draw)  
              (funcall continuation stream))  
         (setq recording-p old-record  
               drawing-p old-draw)))))  
554    
555  (defmacro with-new-output-record ((stream  (defmacro with-new-output-record ((stream
556                                     &optional                                     &optional
# Line 478  recording stream. If it is T, *STANDARD- Line 588  recording stream. If it is T, *STANDARD-
588    (stream-close-text-output-record stream)    (stream-close-text-output-record stream)
589    (unless parent    (unless parent
590      (setq parent (stream-current-output-record stream)))      (setq parent (stream-current-output-record stream)))
591    (let ((new-record (apply #'make-instance record-type :parent parent initargs))    (let ((new-record (apply #'make-instance record-type :parent parent initargs)))
592          (old-record (stream-current-output-record stream)))      (letf (((stream-current-output-record stream) new-record))
593      (unwind-protect        (funcall continuation stream new-record)
594          (progn        (finish-output stream))
595            (setf (stream-current-output-record stream) new-record)      (stream-add-output-record stream new-record)
           (funcall continuation stream new-record)  
           (finish-output stream))  
       (setf (stream-current-output-record stream) old-record)  
       (stream-add-output-record stream new-record))  
596      new-record))      new-record))
597    
598  (defmethod scroll-vertical :around ((stream output-recording-stream) dy)  (defmethod scroll-vertical :around ((stream output-recording-stream) dy)
# Line 692  recording stream. If it is T, *STANDARD- Line 798  recording stream. If it is T, *STANDARD-
798  (defclass text-displayed-output-record (displayed-output-record)  (defclass text-displayed-output-record (displayed-output-record)
799    ((strings :initform nil)    ((strings :initform nil)
800     (baseline :initform 0)     (baseline :initform 0)
801       (width :initform 0)
802     (max-height :initform 0)     (max-height :initform 0)
803     (start-x :initarg :start-x)     (start-x :initarg :start-x)
804     (start-y :initarg :start-y)     (start-y :initarg :start-y)
# Line 715  recording stream. If it is T, *STANDARD- Line 822  recording stream. If it is T, *STANDARD-
822  (defgeneric add-string-output-to-text-record  (defgeneric add-string-output-to-text-record
823    (text-record string start end text-style width height baseline))    (text-record string start end text-style width height baseline))
824  (defgeneric text-displayed-output-record-string (text-record))  (defgeneric text-displayed-output-record-string (text-record))
 ;;; Internal  
 (defgeneric add-character-output-to-text-record  
   (text-record character text-style width height new-baseline))  
 (defgeneric add-string-output-to-text-record  
   (text-record string start end text-style width height new-baseline))  
825    
826  ;;; Methods  ;;; Methods
827  (defmethod tree-recompute-extent ((text-record text-displayed-output-record))  (defmethod tree-recompute-extent ((text-record text-displayed-output-record))
828    (with-slots (parent start-x start-y end-x end-y x1 y1 x2 y2) text-record    (with-slots (parent x y
829                (setq x1 start-x                        x1 y1 x2 y2 width max-height) text-record
830                      x2 end-x                (setq x1 (coordinate x)
831                      y1 start-y                      y1 (coordinate y)
832                      y2 end-y)                      x2 (coordinate (+ x width))
833                (when parent                      y2 (coordinate (+ y max-height)))))
834                  (recompute-extent-for-changed-child parent text-record start-x start-y end-x end-y))))  
835    (defmethod setf*-output-record-position :before (nx ny (record text-displayed-output-record))
836  (defmethod setf*-output-record-position :after (nx ny (record text-displayed-output-record))    (with-slots (x1 y1 x2 y2 x y start-x start-y end-x end-y) record
837    (with-slots (x1 y1 x2 y2 start-x start-y end-x end-y) record                (let ((dx (- nx x))
838                    (setq start-x x1                      (dy (- ny y)))
839                          start-y y1)                  (incf start-x dx)
840                          end-x x2                  (incf start-y dy)
841                          end-y y2))                  (incf end-x dx)
842                    (incf end-y dy))))
843    
844  (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)
845                                                  character text-style width height                                                  character text-style char-width height
846                                                  new-baseline)                                                  new-baseline)
847    (with-slots (strings baseline max-height start-y end-x end-y) text-record    (with-slots (strings baseline width max-height start-y end-x end-y) text-record
848      (if (and strings (eq (second (first (last strings))) text-style))      (if (and strings (eq (second (first (last strings))) text-style))
849          (vector-push-extend character (third (first (last strings))))          (vector-push-extend character (third (first (last strings))))
850        (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))))))
851      (setq baseline (max baseline new-baseline)      (setq baseline (max baseline new-baseline)
852            end-x (+ end-x width)            end-x (+ end-x char-width)
853            max-height (max max-height height)            max-height (max max-height height)
854            end-y (max end-y (+ start-y max-height))            end-y (max end-y (+ start-y max-height))
855            )            width (+ width char-width)))
       )  
856    (tree-recompute-extent text-record))    (tree-recompute-extent text-record))
857    
858  (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)
859                                               string start end text-style width height                                               string start end text-style string-width height
860                                               new-baseline)                                               new-baseline)
861    (if end    (if end
862        (setq end (min end (1- (length string))))        (setq end (min end (1- (length string))))
863        (setq end (1- (length string))))        (setq end (1- (length string))))
864    (let ((length (max 0 (- (1+ end) start))))    (let ((length (max 0 (- (1+ end) start))))
865      (setq string (make-array length :displaced-to string :displaced-index-offset start))      (setq string (make-array length :displaced-to string :displaced-index-offset start))
866      (with-slots (strings baseline max-height start-y end-x end-y) text-record      (with-slots (strings baseline width max-height start-y end-x end-y) text-record
867                  (setq baseline (max baseline new-baseline)                  (setq baseline (max baseline new-baseline)
868                        strings (nconc strings (list (list end-x text-style (make-array (length string) :initial-contents string :element-type 'character :adjustable t :fill-pointer t))))                        strings (nconc strings (list (list end-x text-style (make-array (length string) :initial-contents string :element-type 'character :adjustable t :fill-pointer t))))
869                        end-x (+ end-x width)                        end-x (+ end-x string-width)
870                        max-height (max max-height height)                        max-height (max max-height height)
871                        end-y (max end-y (+ start-y max-height))                        end-y (max end-y (+ start-y max-height))
872                        )))                        width (+ width string-width))))
873    (tree-recompute-extent text-record))    (tree-recompute-extent text-record))
874    
875  (defmethod replay-output-record ((record text-displayed-output-record) stream  (defmethod replay-output-record ((record text-displayed-output-record) stream
# Line 777  recording stream. If it is T, *STANDARD- Line 879  recording stream. If it is T, *STANDARD-
879      (let ((old-medium (sheet-medium stream))      (let ((old-medium (sheet-medium stream))
880            (new-medium (make-medium (port stream) stream)))            (new-medium (make-medium (port stream) stream)))
881        (unwind-protect        (unwind-protect
882            (progn             (progn
883              (setf (sheet-medium stream) new-medium)               (setf (sheet-medium stream) new-medium)
884              (setf (medium-sheet new-medium) stream)               (setf (medium-sheet new-medium) stream)
885              (setf (medium-transformation new-medium)               (setf (medium-transformation new-medium)
886                     (make-translation-transformation                     (make-translation-transformation
887                      (+ x-offset (- x1 initial-x1))                      x-offset
888                      y-offset)))                      y-offset))
889              (loop for y = (+ start-y baseline)  
890                    for (x text-style string) in strings               (setf*-stream-cursor-position start-x start-y stream)
891                    do (setf (medium-text-style new-medium) text-style)               (letf (((slot-value stream 'baseline) baseline))
892                       (draw-text* (sheet-medium stream) string x y                 (loop for (x text-style string) in strings
893                                   :text-style text-style :clipping-region (untransform-region (medium-transformation new-medium) region)))                       do (setf (medium-text-style new-medium) text-style)
894              (if wrapped                       (setf*-stream-cursor-position (+ x (- x1 initial-x1)) start-y stream)
895                  (draw-rectangle* (sheet-medium stream)                       (stream-write-line stream string)))
896                                   (+ wrapped 0) start-y (+ wrapped 4) (+ start-y max-height)               ;; clipping region
897                                   :ink +foreground-ink+               #|restore cursor position? set to (end-x,end-y)?|#
898                                   :filled t)))               #+nil(loop for y = (+ start-y baseline)
899          (setf (sheet-medium stream) old-medium))))                          for (x text-style string) in strings
900                            do (setf (medium-text-style new-medium) text-style)
901                            (draw-text* (sheet-medium stream) string x y
902                                        :text-style text-style :clipping-region (untransform-region (medium-transformation new-medium) region)))
903                 (if wrapped
904                     (draw-rectangle* (sheet-medium stream)
905                                      (+ wrapped 0) start-y (+ wrapped 4) (+ start-y max-height)
906                                      :ink +foreground-ink+
907                                      :filled t)))
908            (setf (sheet-medium stream) old-medium)))))
909    
910  (defmethod output-record-start-cursor-position ((record text-displayed-output-record))  (defmethod output-record-start-cursor-position ((record text-displayed-output-record))
911    (with-slots (start-x start-y) record    (with-slots (start-x start-y) record
# Line 813  recording stream. If it is T, *STANDARD- Line 924  recording stream. If it is T, *STANDARD-
924    
925    
926  ;;; Methods for text output to output recording streams  ;;; Methods for text output to output recording streams
927  (defmethod stream-text-output-record ((stream output-recording-stream) text-style)  (defmethod stream-text-output-record ((stream standard-output-recording-stream) text-style)
928    (let ((record (stream-current-text-output-record stream)))    (let ((record (stream-current-text-output-record stream)))
929      (unless record      (unless record
930        (setf (stream-current-text-output-record stream)        (setf (stream-current-text-output-record stream)
931              (setq record (make-instance 'text-displayed-output-record)))              (setq record (make-instance 'text-displayed-output-record)))
932        (with-slots (start-x start-y end-x end-y x1 y1 x2 y2        (with-slots (start-x start-y end-x end-y x1 y1 x2 y2 x y
933                     initial-x1 initial-y1) record                     initial-x1 initial-y1) record
934            (multiple-value-bind (cx cy) (stream-cursor-position stream)            (multiple-value-bind (cx cy) (stream-cursor-position stream)
935              (setq start-x (coordinate cx)              (setq start-x cx
936                    start-y (coordinate (+ cy (stream-vertical-spacing stream)))                    start-y cy
937                    end-x start-x                    end-x start-x
938                    end-y start-y                    end-y start-y
939                    x1 start-x                    x1 (coordinate start-x)
940                    x2 end-x                    x2 (coordinate end-x)
941                    y1 start-y                    y1 (coordinate start-y)
942                    y2 end-y                    y2 (coordinate end-y)
943                    initial-x1 x1                    initial-x1 x1
944                    initial-y1 start-y                    initial-y1 y1
945                    ))))                    x start-x
946                      y start-y))))
947      record))      record))
948    
949  (defmethod stream-close-text-output-record ((stream output-recording-stream))  (defmethod stream-close-text-output-record ((stream standard-output-recording-stream))
950    (let ((record (stream-current-text-output-record stream)))    (let ((record (stream-current-text-output-record stream)))
951      (when record      (when record
952        (setf (stream-current-text-output-record stream) nil)        (setf (stream-current-text-output-record stream) nil)
953        #|record stream-current-cursor-position to (end-x record) - already done|#        #|record stream-current-cursor-position to (end-x record) - already done|#
954        (stream-add-output-record stream record))))        (stream-add-output-record stream record))))
955    
956  (defmethod stream-add-character-output ((stream output-recording-stream)  (defmethod stream-add-character-output ((stream standard-output-recording-stream)
957                                          character text-style                                          character text-style
958                                          width height baseline)                                          width height baseline)
959    (add-character-output-to-text-record (stream-text-output-record stream text-style)    (add-character-output-to-text-record (stream-text-output-record stream text-style)
960                                         character text-style width height baseline))                                         character text-style width height baseline))
961    
962  (defmethod stream-add-string-output ((stream output-recording-stream)  (defmethod stream-add-string-output ((stream standard-output-recording-stream)
963                                       string start end text-style                                       string start end text-style
964                                       width height baseline)                                       width height baseline)
965    (add-string-output-to-text-record (stream-text-output-record stream text-style)    (add-string-output-to-text-record (stream-text-output-record stream text-style)
# Line 855  recording stream. If it is T, *STANDARD- Line 967  recording stream. If it is T, *STANDARD-
967                                      width height baseline))                                      width height baseline))
968    
969  (defmacro without-local-recording (stream &body body)  (defmacro without-local-recording (stream &body body)
970    (let ((old-local-record-p (gensym)))    `(letf (((slot-value ,stream 'local-record-p) nil))
971      `(with-slots (local-record-p) ,stream      ,@body))
972                   (let ((,old-local-record-p local-record-p))  
973                     (setq local-record-p nil)  (defmethod stream-write-line :around ((stream standard-output-recording-stream) line)
974                     (unwind-protect    (when (and (stream-recording-p stream)
975                         (progn               (slot-value stream 'local-record-p))
976                           ,@body)      (let* ((medium (sheet-medium stream))
977                       (setq local-record-p ,old-local-record-p))))))             (text-style (medium-text-style medium))
978               (port (port stream)))
979          (stream-add-string-output stream line 0 nil text-style
980                                    (stream-string-width stream line
981                                                         :text-style text-style)
982                                    (text-style-height text-style port)
983                                    (text-style-ascent text-style port))))
984      (when (stream-drawing-p stream)
985        (without-local-recording stream
986                                 (call-next-method))))
987    
988  (defmethod stream-write-char :around ((stream output-recording-stream) char)  #+nil
989    (defmethod stream-write-char :around ((stream standard-output-recording-stream) char)
990    (when (and (stream-recording-p stream)    (when (and (stream-recording-p stream)
991               (slot-value stream 'local-record-p))               (slot-value stream 'local-record-p))
992      (if (or (eql char #\return)      (if (or (eql char #\return)
# Line 881  recording stream. If it is T, *STANDARD- Line 1003  recording stream. If it is T, *STANDARD-
1003                             (call-next-method)))                             (call-next-method)))
1004    
1005  #+nil  #+nil
1006  (defmethod stream-write-string :around ((stream output-recording-stream) string  (defmethod stream-write-string :around ((stream standard-output-recording-stream) string
1007                                          &optional (start 0) end)                                          &optional (start 0) end)
1008    ;; Problem: it is necessary to check for line wrapping. Now the    ;; Problem: it is necessary to check for line wrapping. Now the
1009    ;; default method for STREAM-WRITE-STRING do char-by-char output,    ;; default method for STREAM-WRITE-STRING do char-by-char output,
# Line 901  recording stream. If it is T, *STANDARD- Line 1023  recording stream. If it is T, *STANDARD-
1023                             (call-next-method)))                             (call-next-method)))
1024    
1025    
1026  (defmethod stream-finish-output :after ((stream output-recording-stream))  (defmethod stream-finish-output :after ((stream standard-output-recording-stream))
1027    (stream-close-text-output-record stream))    (stream-close-text-output-record stream))
1028    
1029  (defmethod stream-force-output :after ((stream output-recording-stream))  (defmethod stream-force-output :after ((stream standard-output-recording-stream))
1030    (stream-close-text-output-record stream))    (stream-close-text-output-record stream))
1031    
1032  (defmethod stream-terpri :after ((stream output-recording-stream))  (defmethod stream-terpri :after ((stream standard-output-recording-stream))
1033    (stream-close-text-output-record stream))    (stream-close-text-output-record stream))
1034    
1035  (defmethod setf*-stream-cursor-position :after (x y (stream output-recording-stream))  (defmethod setf*-stream-cursor-position :after (x y (stream standard-output-recording-stream))
1036    (stream-close-text-output-record stream))    (stream-close-text-output-record stream))
1037    
1038  ;(defmethod stream-set-cursor-position :after ((stream output-recording-stream))  ;(defmethod stream-set-cursor-position :after ((stream standard-output-recording-stream))
1039  ;  (stream-close-text-output-record stream))  ;  (stream-close-text-output-record stream))
1040    
1041  (defmethod stream-wrap-line :before ((stream output-recording-stream))  (defmethod stream-wrap-line :before ((stream standard-output-recording-stream))
1042    (when (stream-recording-p stream)    (when (stream-recording-p stream)
1043      (setf (text-record-wrapped (stream-text-output-record stream nil)) ; FIXME!      (setf (text-record-wrapped (stream-text-output-record stream nil)) ; FIXME!
1044            (stream-text-margin stream))))            (stream-text-margin stream))))

Legend:
Removed from v.1.21  
changed lines
  Added in v.1.22

  ViewVC Help
Powered by ViewVC 1.1.5