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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.23 - (hide annotations)
Mon Jul 30 14:08:41 2001 UTC (12 years, 8 months ago) by rouanet
Branch: MAIN
Changes since 1.22: +24 -23 lines
Modified the code to make use of the newly implemented setf* facility.
1 mikemac 1.1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2    
3     ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com)
4 cvs 1.4 ;;; (c) copyright 2000 by
5     ;;; Robert Strandh (strandh@labri.u-bordeaux.fr)
6 rouanet 1.11 ;;; (c) copyright 2001 by
7     ;;; Arnaud Rouanet (rouanet@emi.u-bordeaux.fr)
8     ;;; Lionel Salabartan (salabart@emi.u-bordeaux.fr)
9 adejneka 1.20 ;;; Alexey Dejneka (adejneka@comail.ru)
10 mikemac 1.1
11     ;;; This library is free software; you can redistribute it and/or
12     ;;; modify it under the terms of the GNU Library General Public
13     ;;; License as published by the Free Software Foundation; either
14     ;;; version 2 of the License, or (at your option) any later version.
15     ;;;
16     ;;; This library is distributed in the hope that it will be useful,
17     ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18     ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
19     ;;; Library General Public License for more details.
20     ;;;
21     ;;; You should have received a copy of the GNU Library General Public
22     ;;; License along with this library; if not, write to the
23     ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24     ;;; Boston, MA 02111-1307 USA.
25    
26 adejneka 1.21 ;;; TODO:
27     ;;; - Scrolling does not work correctly. Region is given in "window" coordinates,
28     ;;; without bounding-rectangle-position transformation.
29     ;;; - Redo setf*-output-record-position, extent recomputation for
30     ;;; compound records
31     ;;; - How to deal with mixing of positioning/modifying?
32 adejneka 1.22 ;;; - 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 adejneka 1.21
76 mikemac 1.1 (in-package :CLIM-INTERNALS)
77    
78 rouanet 1.11 (defclass output-record-mixin ()
79 mikemac 1.1 ((x :initarg :x-position
80 adejneka 1.22 :initform 0
81     :type rational)
82 mikemac 1.1 (y :initarg :y-position
83 adejneka 1.22 :initform 0
84     :type rational)
85 mikemac 1.1 (parent :initarg :parent
86 rouanet 1.11 :initform nil
87     :reader output-record-parent)))
88    
89 rouanet 1.13 (defmethod initialize-instance :after ((record output-record-mixin) &rest args)
90     (declare (ignore args))
91 rouanet 1.11 (with-slots (x1 y1 x2 y2) record
92     (setq x1 0
93     y1 0
94     x2 0
95     y2 0)))
96    
97     (defclass output-record (standard-bounding-rectangle output-record-mixin)
98     ((children :initform nil
99     :reader output-record-children))
100 mikemac 1.1 (:default-initargs :min-x 0 :min-y 0 :max-x 0 :max-y 0))
101    
102     (defun output-record-p (x)
103     (typep x 'output-record))
104    
105 rouanet 1.11 (defclass displayed-output-record (standard-bounding-rectangle output-record-mixin)
106 rouanet 1.18 ((ink :initarg :ink :reader displayed-output-record-ink)
107     (initial-x1 :initarg :initial-x1)
108     (initial-y1 :initarg :initial-y1)))
109 mikemac 1.1
110     (defun displayed-output-record-p (x)
111     (typep x 'displayed-output-record))
112    
113 adejneka 1.21 ; 16.2.1. The Basic Output Record Protocol
114 adejneka 1.22 (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 rouanet 1.23 (defgeneric* (setf output-record-position) (x y record))
124 adejneka 1.22
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 rouanet 1.23 (defgeneric* (setf output-record-start-cursor-position) (x y record))
134 adejneka 1.22
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 rouanet 1.23 (defgeneric* (setf output-record-end-cursor-position) (x y record))
144 adejneka 1.22
145     (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 adejneka 1.21 (defgeneric replay-output-record (record stream
154 adejneka 1.22 &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 adejneka 1.21 (defgeneric output-record-hit-detection-rectangle* (record))
164 adejneka 1.22
165 adejneka 1.21 (defgeneric output-record-refined-position-test (record x y))
166 adejneka 1.22
167 adejneka 1.21 (defgeneric highlight-output-record (record stream state))
168 adejneka 1.22
169 adejneka 1.21 (defgeneric displayed-output-record-ink (displayed-output-record))
170    
171     ; 16.2.2. Output Record "Database" Protocol
172 adejneka 1.22
173 adejneka 1.21 (defgeneric output-record-children (record))
174 adejneka 1.22
175 adejneka 1.21 (defgeneric add-output-record (child record))
176 adejneka 1.22
177 adejneka 1.21 (defgeneric delete-output-record (child record &optional (errorp t)))
178 adejneka 1.22
179 adejneka 1.21 (defgeneric clear-output-record (record))
180 adejneka 1.22
181 adejneka 1.21 (defgeneric output-record-count (record))
182 adejneka 1.22
183 adejneka 1.21 (defgeneric map-over-output-records-containing-position
184     (function record x y &optional x-offset y-offset &rest function-args))
185 adejneka 1.22
186 adejneka 1.21 (defgeneric map-over-output-records-overlapping-region
187     (function record region &optional x-offset y-offset &rest function-args))
188    
189     ; 16.2.3. Output Record Change Notification Protocol
190 adejneka 1.22
191 adejneka 1.21 (defgeneric recompute-extent-for-new-child (record child))
192 adejneka 1.22
193 adejneka 1.21 (defgeneric recompute-extent-for-changed-child
194     (record child old-min-x old-min-y old-max-x old-max-y))
195 adejneka 1.22
196 adejneka 1.21 (defgeneric tree-recompute-extent (record))
197    
198     ;;; Methods
199 adejneka 1.22
200 rouanet 1.11 (defmethod initialize-instance :after ((record output-record) &rest args
201 mikemac 1.1 &key size
202     &allow-other-keys)
203     (declare (ignore args size)))
204    
205 rouanet 1.11 (defmethod output-record-position ((record output-record-mixin))
206 mikemac 1.1 (with-slots (x y) record
207     (values x y)))
208    
209 rouanet 1.23 (defmethod* (setf output-record-position) (nx ny (record output-record-mixin))
210 rouanet 1.18 (with-slots (x y x1 y1 x2 y2) record
211     (let ((dx (- nx x))
212     (dy (- ny y)))
213     (incf x1 dx) (incf y1 dy)
214     (incf x2 dx) (incf y2 dy))
215     (setq x nx
216     y ny)))
217 mikemac 1.1
218 rouanet 1.23 (defmethod* (setf output-record-position) :before (nx ny (record output-record))
219 rouanet 1.11 (multiple-value-bind (old-x old-y) (output-record-position record)
220     (loop with dx = (- nx old-x)
221     and dy = (- ny old-y)
222     for child in (output-record-children record)
223     do (multiple-value-bind (x y) (output-record-position child)
224 rouanet 1.23 (setf (output-record-position child) (values (+ x dx) (+ y dy)))))))
225 rouanet 1.11
226 rouanet 1.23 (defmethod* (setf output-record-position) :around (nx ny (record output-record-mixin))
227 rouanet 1.11 (declare (ignore nx ny))
228     (with-bounding-rectangle* (min-x min-y max-x max-y) record
229     (call-next-method)
230 adejneka 1.16 (let ((parent (output-record-parent record)))
231     (when parent
232     (recompute-extent-for-changed-child parent record
233     min-x min-y max-x max-y)))))
234 rouanet 1.11
235 mikemac 1.1 (defmethod output-record-start-cursor-position ((record displayed-output-record))
236     (values nil nil))
237    
238 rouanet 1.23 (defmethod* (setf output-record-start-cursor-position) (x y (record displayed-output-record))
239 mikemac 1.1 (declare (ignore x y))
240     nil)
241    
242     (defmethod output-record-end-cursor-position ((record displayed-output-record))
243     (values nil nil))
244    
245 rouanet 1.23 (defmethod* (setf output-record-end-cursor-position) (x y (record displayed-output-record))
246 mikemac 1.1 (declare (ignore x y))
247     nil)
248    
249 adejneka 1.22 (defmethod replay (record stream &optional region)
250 adejneka 1.21 (stream-close-text-output-record stream)
251 rouanet 1.11 (when (stream-drawing-p stream)
252 adejneka 1.22 (with-cursor-off stream
253     (multiple-value-bind (cx cy) (stream-cursor-position stream)
254     (unwind-protect
255     (letf (((stream-recording-p stream) nil))
256     (replay-output-record record stream region))
257 rouanet 1.23 (setf (stream-cursor-position stream) (values cx cy)))))))
258 mikemac 1.1
259     (defmethod replay-output-record ((record output-record) stream
260 rouanet 1.18 &optional region (x-offset 0) (y-offset 0))
261 rouanet 1.11 (when (null region)
262     (setq region +everywhere+))
263     (map-over-output-records-overlaping-region
264     #'replay-output-record record region x-offset y-offset
265     stream region x-offset y-offset))
266 mikemac 1.1
267 adejneka 1.21 (defmethod erase-output-record ((record output-record) stream &optional (errorp t))
268 mikemac 1.1 (declare (ignore stream))
269     nil)
270    
271 rouanet 1.11 (defmethod output-record-hit-detection-rectangle* ((record output-record-mixin))
272 mikemac 1.1 (bounding-rectangle* record))
273    
274 rouanet 1.11 (defmethod output-record-refined-sensitivity-test ((record output-record-mixin) x y)
275 rouanet 1.13 (declare (ignore x y))
276     t)
277 mikemac 1.1
278 rouanet 1.11 (defmethod highlight-output-record ((record output-record-mixin) stream state)
279 mikemac 1.1 (multiple-value-bind (x1 y1 x2 y2) (output-record-hit-detection-rectangle* record)
280     (ecase state
281     (:highlight
282 rouanet 1.11 (draw-rectangle* (sheet-medium stream) x1 y1 x2 y2 :filled nil :ink +foreground-ink+))
283 mikemac 1.1 (:unhighlight
284 rouanet 1.11 (draw-rectangle* (sheet-medium stream) x1 y1 x2 y2 :filled nil :ink +background-ink+)))))
285    
286     (defclass standard-sequence-output-record (output-record)
287     (
288     ))
289    
290     (defclass standard-tree-output-record (output-record)
291     (
292     ))
293    
294 rouanet 1.23 (defmethod* (setf output-record-position) (nx ny (record standard-sequence-output-record))
295 adejneka 1.21 (with-slots (x y) record
296 rouanet 1.23 (setq x nx
297     y ny)))
298 adejneka 1.21
299 rouanet 1.11 (defmethod output-record-children ((output-record output-record))
300     (with-slots (children) output-record
301     (reverse children)))
302 mikemac 1.1
303     (defmethod add-output-record (child (record output-record))
304     (with-slots (children) record
305     (push child children))
306     (with-slots (parent) child
307     (setf parent record)))
308    
309 rouanet 1.11 (defmethod add-output-record :before (child (record output-record))
310     (when (null (output-record-children record))
311     (with-bounding-rectangle* (min-x min-y max-x max-y) child
312     (with-slots (x1 y1 x2 y2) record
313     (setq x1 min-x
314     y1 min-y
315     x2 max-x
316     y2 max-y)))))
317    
318     (defmethod add-output-record :after (child (record output-record))
319     (recompute-extent-for-new-child record child))
320    
321 mikemac 1.1 (defmethod delete-output-record (child (record output-record) &optional (errorp t))
322     (with-slots (children) record
323     (if (and errorp
324     (not (member child children)))
325     (error "~S is not a child of ~S" child record))
326     (setq children (delete child children))))
327    
328 rouanet 1.11 (defmethod delete-output-record :after (child (record output-record) &optional (errorp t))
329     (declare (ignore errorp))
330     (with-bounding-rectangle* (x1 y1 x2 y2) child
331     (recompute-extent-for-changed-child record child x1 y1 x2 y2)))
332    
333 mikemac 1.1 (defmethod clear-output-record ((record output-record))
334 cvs 1.3 (with-slots (children x1 y1 x2 y2) record
335 mikemac 1.1 (setq children nil
336 adejneka 1.21 x1 (coordinate 0)
337     y1 (coordinate 0)
338     x2 (coordinate 0)
339     y2 (coordinate 0))))
340 mikemac 1.1
341     (defmethod output-record-count ((record output-record))
342     (length (output-record-children record)))
343    
344     (defmethod map-over-output-records-containing-position (function (record output-record) x y
345 rouanet 1.11 &optional (x-offset 0) (y-offset 0)
346     &rest function-args)
347 mikemac 1.1 (declare (dynamic-extent function)
348     (ignore x-offset y-offset))
349     (loop for child in (output-record-children record)
350 rouanet 1.13 when (and (region-contains-position-p
351     (multiple-value-call #'make-bounding-rectangle
352     (output-record-hit-detection-rectangle* child))
353     x y)
354     (output-record-refined-sensitivity-test child x y))
355     do (apply function child function-args)))
356 mikemac 1.1
357     (defmethod map-over-output-records-overlaping-region (function (record output-record) region
358 rouanet 1.11 &optional (x-offset 0) (y-offset 0)
359     &rest function-args)
360 mikemac 1.1 (declare (dynamic-extent function)
361     (ignore x-offset y-offset))
362 rouanet 1.11 (loop for child in (output-record-children record)
363     do (when (region-intersects-region-p region child)
364     (apply function child function-args))))
365 mikemac 1.1
366     (defmethod recompute-extent-for-new-child ((record output-record) child)
367 rouanet 1.11 (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2) record
368     (with-slots (parent x1 y1 x2 y2) record
369     (with-bounding-rectangle* (x1-child y1-child x2-child y2-child) child
370     (setq x1 (min x1 x1-child)
371     y1 (min y1 y1-child)
372     x2 (max x2 x2-child)
373     y2 (max y2 y2-child)))
374     (when parent
375     (recompute-extent-for-changed-child parent record old-x1 old-y1 old-x2 old-y2)))))
376 mikemac 1.1
377 rouanet 1.11 (defmethod recompute-extent-for-changed-child :around ((record output-record) child
378     old-min-x old-min-y old-max-x old-max-y)
379     (declare (ignore child old-min-x old-min-y old-max-x old-max-y))
380     (let ((old-rectangle (multiple-value-call #'make-bounding-rectangle
381     (bounding-rectangle* record))))
382     (call-next-method)
383     (with-slots (parent x1 y1 x2 y2) record
384 adejneka 1.21 (when (and parent (not (region-equal old-rectangle record)))
385 rouanet 1.11 (recompute-extent-for-changed-child parent record x1 y1 x2 y2)))))
386    
387     (defmethod recompute-extent-for-changed-child ((record output-record) changed-child
388 mikemac 1.1 old-min-x old-min-y old-max-x old-max-y)
389 rouanet 1.11 (with-slots (children x1 y1 x2 y2) record
390     (with-bounding-rectangle* (new-x1 new-y1 new-x2 new-y2) changed-child
391     (setq x1 (min x1 new-x1)
392     y1 (min y1 new-y1)
393     x2 (max x2 new-x2)
394     y2 (max y2 new-y2)))
395     (if (null children)
396     (clear-output-record record)
397     (when (or (coordinate= x1 old-min-x)
398     (coordinate= y1 old-min-y)
399     (coordinate= x2 old-max-x)
400     (coordinate= y2 old-max-y))
401     (with-bounding-rectangle* (left top right bottom) (first children)
402     (loop for child in (rest children)
403     do (with-bounding-rectangle* (x1-child y1-child x2-child y2-child) child
404     (setq left (min left x1-child)
405     top (min top y1-child)
406     right (max right x2-child)
407     bottom (max bottom y2-child))))
408     (setq x1 left
409     y1 top
410     x2 right
411     y2 bottom))))))
412 mikemac 1.1
413     (defmethod tree-recompute-extent ((record output-record))
414 adejneka 1.22 (with-slots (children x1 y1 x2 y2) record
415 mikemac 1.1 (if (null children)
416 adejneka 1.21 (setq x1 (coordinate 0)
417     y1 (coordinate 0)
418     x2 (coordinate 0)
419     y2 (coordinate 0))
420 mikemac 1.1 (with-bounding-rectangle* (left top right bottom) (first children)
421     (loop for child in (rest children)
422     do (with-bounding-rectangle* (l1 t1 r1 b1) child
423     (setq left (min left l1 r1)
424     top (min top t1 b1)
425     right (max right l1 r1)
426     bottom (max bottom t1 b1))))
427 cvs 1.3 (setq x1 left
428     y1 top
429     x2 right
430 adejneka 1.22 y2 bottom)))))
431    
432     (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 mikemac 1.1
440    
441     ;;; Graphics recording classes
442    
443     (defclass graphics-displayed-output-record (displayed-output-record)
444 adejneka 1.14 ((clip :initarg :clipping-region
445     :documentation "Clipping region in user coordinates.")
446 mikemac 1.1 (transform :initarg :transformation)
447     (line-style :initarg :line-style)
448     (text-style :initarg :text-style)
449     ))
450    
451     (defun graphics-displayed-output-record-p (x)
452     (typep x 'graphics-displayed-output-record))
453    
454    
455     ;;; stream-output-history-mixin class
456    
457     (defclass stream-output-history-mixin ()
458 rouanet 1.11 ())
459    
460     (defclass standard-sequence-output-history (standard-sequence-output-record stream-output-history-mixin)
461     ())
462    
463     (defclass standard-tree-output-history (standard-tree-output-record stream-output-history-mixin)
464     ())
465    
466    
467     ;;; Output-Recording-Stream class
468    
469     (defclass output-recording-stream ()
470     ((recording-p :initform t :accessor stream-recording-p)
471     (drawing-p :initform t :accessor stream-drawing-p)
472     (output-history :initform (make-instance 'standard-tree-output-history)
473     :reader stream-output-history)
474 adejneka 1.20 (current-output-record :accessor stream-current-output-record)
475     (current-text-output-record :initform nil :accessor stream-current-text-output-record)
476     (local-record-p :initform t
477     :documentation "This flag is used for dealing with streams outputting strings char-by-char.")))
478 rouanet 1.11
479     (defun output-recording-stream-p (x)
480     (typep x 'output-recording-stream))
481    
482     (defclass standard-output-recording-stream (output-recording-stream)
483     (
484 mikemac 1.1 ))
485    
486 adejneka 1.21 ;;; 16.4.1 The Output Recording Stream Protocol
487     (defgeneric stream-recording-p (stream))
488 adejneka 1.22
489 adejneka 1.21 (defgeneric (setf stream-recording-p) (recording-p stream))
490 adejneka 1.22
491 adejneka 1.21 (defgeneric stream-drawing-p (stream))
492 adejneka 1.22
493 adejneka 1.21 (defgeneric (setf stream-drawing-p) (drawing-p stream))
494 adejneka 1.22
495 adejneka 1.21 (defgeneric stream-output-history (stream))
496 adejneka 1.22
497 adejneka 1.21 (defgeneric stream-current-output-record (stream))
498 adejneka 1.22
499 adejneka 1.21 (defgeneric (setf stream-current-output-record) (record stream))
500 adejneka 1.22
501 adejneka 1.21 (defgeneric stream-add-output-record (stream record))
502 adejneka 1.22
503 adejneka 1.21 (defgeneric stream-replay (stream &optional region))
504 adejneka 1.22
505 adejneka 1.21 (defgeneric erase-output-record (record stream &optional (errorp t)))
506 adejneka 1.22
507 adejneka 1.21 (defgeneric copy-textual-output-history (window stream &optional region record))
508    
509     ;;; 16.4.3 Text Output Recording
510 adejneka 1.22
511 adejneka 1.21 (defgeneric stream-text-output-record (stream text-style))
512 adejneka 1.22
513 adejneka 1.21 (defgeneric stream-close-text-output-record (stream))
514 adejneka 1.22
515 adejneka 1.21 (defgeneric stream-add-character-output
516     (stream character text-style width height baseline))
517 adejneka 1.22
518 adejneka 1.21 (defgeneric stream-add-string-output
519     (stream string start end text-style width height baseline))
520    
521     ;;; Methods
522 rouanet 1.11 (defmethod initialize-instance :after ((stream output-recording-stream) &rest args)
523     (declare (ignore args))
524     (setf (stream-current-output-record stream) (stream-output-history stream)))
525    
526     (defmethod stream-add-output-record ((stream output-recording-stream) record)
527 adejneka 1.16 (add-output-record record (stream-current-output-record stream)))
528 rouanet 1.11
529     (defmethod stream-replay ((stream output-recording-stream) &optional region)
530     (replay (stream-output-history stream) stream region))
531    
532 cvs 1.10 (defmacro with-output-recording-options ((stream &key (record t) (draw t)) &body body)
533 adejneka 1.16 (declare (type symbol stream))
534     (when (eq stream 't)
535 rouanet 1.18 (setq stream '*standard-output*))
536 adejneka 1.16 (let ((continuation-name (gensym)))
537     `(let ((,continuation-name #'(lambda (,stream) ,@body)))
538     (invoke-with-output-recording-options ,stream
539     ,continuation-name
540     ,record
541     ,draw))))
542    
543     (defmethod invoke-with-output-recording-options
544     ((stream output-recording-stream) continuation record draw)
545     "Calls CONTINUATION on STREAM enabling or disabling recording and drawing
546     according to the flags RECORD and DRAW."
547 rouanet 1.18 (declare (dynamic-extent continuation))
548 adejneka 1.16 (with-slots (recording-p drawing-p) stream
549 adejneka 1.22 (unless (eq recording-p record)
550     (stream-close-text-output-record stream))
551     (letf ((recording-p record)
552     (drawing-p draw))
553     (funcall continuation stream))))
554 adejneka 1.16
555     (defmacro with-new-output-record ((stream
556     &optional
557 rouanet 1.18 (record-type 'standard-sequence-output-record)
558 adejneka 1.16 (record nil record-supplied-p)
559     &rest initargs)
560     &body body)
561     "Creates a new output record of type RECORD-TYPE and then captures
562     the output of BODY into the new output record, and inserts the new
563     record into the current \"open\" output record assotiated with STREAM.
564     If RECORD is supplied, it is the name of a variable that will be
565     lexically bound to the new output record inside the body. INITARGS are
566     CLOS initargs that are passed to MAKE-INSTANCE when the new output
567     record is created.
568     It returns the created output record.
569     The STREAM argument is a symbol that is bound to an output
570     recording stream. If it is T, *STANDARD-OUTPUT* is used."
571     (declare (type symbol stream record))
572     (when (eq stream 't)
573     (setq stream '*standard-output*))
574     (unless record-supplied-p
575     (setq record (gensym)))
576     `(invoke-with-new-output-record
577     ,stream
578     #'(lambda (,stream ,record)
579 adejneka 1.19 ,@(unless record-supplied-p `((declare (ignore ,record))))
580 adejneka 1.16 ,@body)
581 rouanet 1.18 ',record-type
582 adejneka 1.16 ,@initargs))
583    
584     (defmethod invoke-with-new-output-record ((stream output-recording-stream)
585     continuation record-type
586     &rest initargs
587     &key parent)
588 adejneka 1.20 (stream-close-text-output-record stream)
589 adejneka 1.16 (unless parent
590     (setq parent (stream-current-output-record stream)))
591 adejneka 1.22 (let ((new-record (apply #'make-instance record-type :parent parent initargs)))
592     (letf (((stream-current-output-record stream) new-record))
593     (funcall continuation stream new-record)
594     (finish-output stream))
595     (stream-add-output-record stream new-record)
596 adejneka 1.16 new-record))
597 cvs 1.10
598 rouanet 1.11 (defmethod scroll-vertical :around ((stream output-recording-stream) dy)
599 mikemac 1.1 (declare (ignore dy))
600     (with-output-recording-options (stream :record nil)
601     (call-next-method)))
602    
603 rouanet 1.11 (defmethod scroll-horizontal :around ((stream output-recording-stream) dx)
604 mikemac 1.1 (declare (ignore dx))
605     (with-output-recording-options (stream :record nil)
606     (call-next-method)))
607    
608 rouanet 1.11 (defmethod repaint-sheet ((stream output-recording-stream) region)
609     (stream-replay stream region))
610 cvs 1.7
611 rouanet 1.11 (defmethod handle-event ((stream output-recording-stream) (event window-repaint-event))
612 rouanet 1.12 (repaint-sheet stream (window-event-region event)))
613 cvs 1.7
614 rouanet 1.11 (defmethod handle-event ((stream output-recording-stream) (event pointer-button-press-event))
615 cvs 1.7 (with-slots (button x y) event
616     (format *debug-io* "button ~D pressed at ~D,~D~%" button x y)))
617    
618 rouanet 1.11 #|
619     (defmethod handle-event :after ((stream output-recording-stream) (event pointer-button-press-event))
620 rouanet 1.18 (highlight-output-record (stream-current-output-record stream) stream :highlight))
621 rouanet 1.11
622     (defmethod handle-event :before ((stream output-recording-stream) (event pointer-button-release-event))
623 rouanet 1.18 (highlight-output-record (stream-current-output-record stream) stream :unhighlight))
624 rouanet 1.11 |#
625 mikemac 1.1
626    
627 adejneka 1.21 ;;; Graphics and text recording classes
628 mikemac 1.1
629     (eval-when (compile load eval)
630    
631     (defun compute-class-vars (names)
632     (cons (list 'stream :initarg :stream)
633     (loop for name in names
634 cvs 1.2 collecting (list name :initarg (intern (symbol-name name) :keyword)))))
635 mikemac 1.1
636     (defun compute-arg-list (names)
637     (loop for name in names
638 cvs 1.2 nconcing (list (intern (symbol-name name) :keyword) name)))
639 mikemac 1.1 )
640    
641     (defun make-merged-medium (sheet ink clip transform line-style text-style)
642     (let ((medium (make-medium (port sheet) sheet)))
643     (setf (medium-ink medium) ink)
644 adejneka 1.14 ;; First set transformation, then clipping region!
645     (setf (medium-transformation medium) transform)
646 mikemac 1.1 (setf (medium-clipping-region medium) clip)
647     (setf (medium-line-style medium) line-style)
648     (setf (medium-text-style medium) text-style)
649     medium))
650    
651     (defmacro def-grecording (name (&rest args) &body body)
652     (let ((method-name (intern (format nil "MEDIUM-~A*" name)))
653     (class-name (intern (format nil "~A-OUTPUT-RECORD" name)))
654     (old-medium (gensym))
655 rouanet 1.12 (new-medium (gensym))
656     (border (gensym)))
657 cvs 1.10 `(progn
658 mikemac 1.1 (defclass ,class-name (graphics-displayed-output-record)
659     ,(compute-class-vars args))
660     (defmethod initialize-instance :after ((graphic ,class-name) &rest args)
661     (declare (ignore args))
662 rouanet 1.18 (with-slots (x y x1 y1 x2 y2 initial-x1 initial-y1
663 adejneka 1.14 stream ink clipping-region transform
664 mikemac 1.1 line-style text-style
665     ,@args) graphic
666 rouanet 1.12 (let ((,border (1+ (/ (line-style-thickness line-style) 2))))
667     (multiple-value-bind (lf tp rt bt) (progn ,@body)
668     (setq x1 (- lf ,border)
669     y1 (- tp ,border)
670     x2 (+ rt ,border)
671 rouanet 1.18 y2 (+ bt ,border))))
672     (setf x x1
673     y y1
674     initial-x1 x1
675     initial-y1 y1)))
676 rouanet 1.11 (defmethod ,method-name :around ((stream output-recording-stream) ,@args)
677 mikemac 1.1 (with-sheet-medium (medium stream)
678 cvs 1.5 (when (stream-recording-p stream)
679     (let ((record (make-instance ',class-name
680     :stream stream
681     :ink (medium-ink medium)
682     :clipping-region (medium-clipping-region medium)
683     :transformation (medium-transformation medium)
684     :line-style (medium-line-style medium)
685     :text-style (medium-text-style medium)
686     ,@(compute-arg-list args))))
687 rouanet 1.11 (stream-add-output-record stream record)))
688 cvs 1.5 (when (stream-drawing-p stream)
689     (call-next-method))))
690 mikemac 1.1 (defmethod replay-output-record ((record ,class-name) stream
691 rouanet 1.18 &optional (region +everywhere+)
692     (x-offset 0) (y-offset 0))
693     (with-slots (x y initial-x1 initial-y1
694     ink clip transform line-style text-style ,@args) record
695     (let ((transformation (compose-translation-with-transformation
696     transform
697     (+ (- x initial-x1) x-offset)
698     (+ (- y initial-y1) y-offset))))
699     (let ((,old-medium (sheet-medium stream))
700     (,new-medium (make-merged-medium stream ink
701     (region-intersection clip
702     (untransform-region transformation region))
703     transformation line-style text-style)))
704     (unwind-protect
705     (progn
706     (setf (sheet-medium stream) ,new-medium)
707     (setf (medium-sheet ,new-medium) stream)
708     (,method-name ,new-medium ,@args))
709     (setf (sheet-medium stream) ,old-medium)))))))))
710 mikemac 1.1
711 rouanet 1.11 (def-grecording draw-point (point-x point-y)
712 adejneka 1.14 (with-transformed-position (transform point-x point-y)
713     (values point-x point-y point-x point-y)))
714 mikemac 1.1
715     (def-grecording draw-points (coord-seq)
716 adejneka 1.14 (with-transformed-positions (transform coord-seq)
717     (loop for (x y) on coord-seq by #'cddr
718     minimize x into min-x
719     minimize y into min-y
720     maximize x into max-x
721     maximize y into max-y
722     finally (return (values min-x min-y max-x max-y)))))
723 mikemac 1.1
724 rouanet 1.11 (def-grecording draw-line (point-x1 point-y1 point-x2 point-y2)
725 adejneka 1.14 (with-transformed-position (transform point-x1 point-y1)
726     (with-transformed-position (transform point-x2 point-y2)
727     (values (min point-x1 point-x2) (min point-y1 point-y2)
728     (max point-x1 point-x2) (max point-y1 point-y2)))))
729 mikemac 1.1
730     (def-grecording draw-lines (coord-seq)
731 adejneka 1.14 (with-transformed-positions (transform coord-seq)
732     (loop for (x y) on coord-seq by #'cddr
733     minimize x into min-x
734     minimize y into min-y
735     maximize x into max-x
736     maximize y into max-y
737     finally (return (values min-x min-y max-x max-y)))))
738 mikemac 1.1
739     (def-grecording draw-polygon (coord-seq closed filled)
740 adejneka 1.16 ;; FIXME !!!
741     ;; If LINE-STYLE-JOINT-SHAPE is :MITTER, then the bb is larger than
742     ;; these numbers by (LINE-THICKNESS / (sin (angle / 2))),
743     ;; which is larger than LINE-THICKNESS
744 adejneka 1.14 (with-transformed-positions (transform coord-seq)
745     (loop for (x y) on coord-seq by #'cddr
746     minimize x into min-x
747     minimize y into min-y
748     maximize x into max-x
749     maximize y into max-y
750     finally (return (values min-x min-y max-x max-y)))))
751 mikemac 1.1
752     (def-grecording draw-rectangle (left top right bottom filled)
753 adejneka 1.17 ;; FIXME!!! If the rectangle is a line/point, MAKE-RECTANGLE* gives +NOWHERE+,
754     ;; and BOUNDING-RECTANGLE* signals an error.
755     (bounding-rectangle* (transform-region transform
756     (make-rectangle* left top right bottom))))
757 mikemac 1.1
758     (def-grecording draw-ellipse (center-x center-y
759     radius-1-dx radius-1-dy radius-2-dx radius-2-dy
760     start-angle end-angle filled)
761 adejneka 1.17 (bounding-rectangle* (transform-region transform
762     (make-ellipse* center-x center-y
763     radius-1-dx radius-1-dy radius-2-dx radius-2-dy
764     :start-angle start-angle
765     :end-angle end-angle))))
766 rouanet 1.11
767     (def-grecording draw-text (string point-x point-y start end
768     align-x align-y toward-x toward-y transform-glyphs)
769 adejneka 1.16 ;; FIXME!!! transformation
770 rouanet 1.11 (let* ((width (stream-string-width stream string
771     :start start :end end
772     :text-style text-style))
773     (ascent (text-style-ascent text-style (port (sheet-medium stream))))
774     (descent (text-style-descent text-style (port (sheet-medium stream))))
775     (height (+ ascent descent))
776     left top right bottom)
777     (ecase align-x
778     (:left (setq left point-x
779     right (+ point-x width)))
780     (:right (setq left (- point-x width)
781     right point-x))
782     (:center (setq left (- point-x (round width 2))
783     right (+ point-x (round width 2)))))
784     (ecase align-y
785     (:baseline (setq top (- point-y height)
786     bottom (+ point-y descent)))
787     (:top (setq top point-y
788     bottom (+ point-y height)))
789     (:bottom (setq top (- point-y height)
790     bottom point-y))
791     (:center (setq top (- point-y (floor height 2))
792     bottom (+ point-y (ceiling height 2)))))
793     (values left top right bottom)))
794 mikemac 1.1
795    
796     ;;; Text recording class
797    
798     (defclass text-displayed-output-record (displayed-output-record)
799     ((strings :initform nil)
800     (baseline :initform 0)
801 adejneka 1.22 (width :initform 0)
802 mikemac 1.1 (max-height :initform 0)
803 cvs 1.6 (start-x :initarg :start-x)
804     (start-y :initarg :start-y)
805 mikemac 1.1 (end-x)
806 cvs 1.8 (end-y)
807     (wrapped :initform nil
808 adejneka 1.21 :accessor text-record-wrapped)))
809 mikemac 1.1
810     (defun text-displayed-output-record-p (x)
811     (typep x 'text-displayed-output-record))
812    
813 cvs 1.8 (defmethod print-object ((self text-displayed-output-record) stream)
814     (print-unreadable-object (self stream :type t :identity t)
815     (if (slot-boundp self 'start-x)
816     (with-slots (start-x start-y strings) self
817     (format stream "~D,~D ~S" start-x start-y (mapcar #'third strings)))
818     (format stream "empty"))))
819 mikemac 1.1
820 adejneka 1.21 (defgeneric add-character-output-to-text-record
821     (text-record character text-style width height baseline))
822     (defgeneric add-string-output-to-text-record
823     (text-record string start end text-style width height baseline))
824     (defgeneric text-displayed-output-record-string (text-record))
825    
826     ;;; Methods
827 cvs 1.9 (defmethod tree-recompute-extent ((text-record text-displayed-output-record))
828 adejneka 1.22 (with-slots (parent x y
829     x1 y1 x2 y2 width max-height) text-record
830     (setq x1 (coordinate x)
831     y1 (coordinate y)
832     x2 (coordinate (+ x width))
833     y2 (coordinate (+ y max-height)))))
834    
835 rouanet 1.23 (defmethod* (setf output-record-position) :before (nx ny (record text-displayed-output-record))
836 adejneka 1.22 (with-slots (x1 y1 x2 y2 x y start-x start-y end-x end-y) record
837 rouanet 1.23 (let ((dx (- nx x))
838     (dy (- ny y)))
839     (incf start-x dx)
840     (incf start-y dy)
841     (incf end-x dx)
842     (incf end-y dy))))
843 cvs 1.9
844 mikemac 1.1 (defmethod add-character-output-to-text-record ((text-record text-displayed-output-record)
845 adejneka 1.22 character text-style char-width height
846 mikemac 1.1 new-baseline)
847 adejneka 1.22 (with-slots (strings baseline width max-height start-y end-x end-y) text-record
848 cvs 1.7 (if (and strings (eq (second (first (last strings))) text-style))
849     (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))))))
851     (setq baseline (max baseline new-baseline)
852 adejneka 1.22 end-x (+ end-x char-width)
853 mikemac 1.1 max-height (max max-height height)
854 cvs 1.9 end-y (max end-y (+ start-y max-height))
855 adejneka 1.22 width (+ width char-width)))
856 cvs 1.9 (tree-recompute-extent text-record))
857 mikemac 1.1
858     (defmethod add-string-output-to-text-record ((text-record text-displayed-output-record)
859 adejneka 1.22 string start end text-style string-width height
860 mikemac 1.1 new-baseline)
861 adejneka 1.20 (if end
862 adejneka 1.21 (setq end (min end (1- (length string))))
863 adejneka 1.20 (setq end (1- (length string))))
864     (let ((length (max 0 (- (1+ end) start))))
865     (setq string (make-array length :displaced-to string :displaced-index-offset start))
866 adejneka 1.22 (with-slots (strings baseline width max-height start-y end-x end-y) text-record
867 adejneka 1.20 (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))))
869 adejneka 1.22 end-x (+ end-x string-width)
870 adejneka 1.20 max-height (max max-height height)
871     end-y (max end-y (+ start-y max-height))
872 adejneka 1.22 width (+ width string-width))))
873 adejneka 1.20 (tree-recompute-extent text-record))
874 mikemac 1.1
875     (defmethod replay-output-record ((record text-displayed-output-record) stream
876 adejneka 1.21 &optional region (x-offset 0) (y-offset 0))
877 adejneka 1.20 (with-slots (strings baseline max-height start-x start-y wrapped
878 adejneka 1.21 x y x1 y1 initial-x1 initial-y1) record
879 cvs 1.7 (let ((old-medium (sheet-medium stream))
880     (new-medium (make-medium (port stream) stream)))
881     (unwind-protect
882 adejneka 1.22 (progn
883     (setf (sheet-medium stream) new-medium)
884     (setf (medium-sheet new-medium) stream)
885     (setf (medium-transformation new-medium)
886 adejneka 1.20 (make-translation-transformation
887 adejneka 1.22 x-offset
888     y-offset))
889    
890 rouanet 1.23 (setf (stream-cursor-position stream) (values start-x start-y))
891 adejneka 1.22 (letf (((slot-value stream 'baseline) baseline))
892     (loop for (x text-style string) in strings
893     do (setf (medium-text-style new-medium) text-style)
894 rouanet 1.23 (setf (stream-cursor-position stream)
895     (values (+ x (- x1 initial-x1)) start-y))
896 adejneka 1.22 (stream-write-line stream string)))
897     ;; clipping region
898     #|restore cursor position? set to (end-x,end-y)?|#
899     #+nil(loop for y = (+ start-y baseline)
900     for (x text-style string) in strings
901     do (setf (medium-text-style new-medium) text-style)
902     (draw-text* (sheet-medium stream) string x y
903     :text-style text-style :clipping-region (untransform-region (medium-transformation new-medium) region)))
904     (if wrapped
905     (draw-rectangle* (sheet-medium stream)
906     (+ wrapped 0) start-y (+ wrapped 4) (+ start-y max-height)
907     :ink +foreground-ink+
908     :filled t)))
909     (setf (sheet-medium stream) old-medium)))))
910 mikemac 1.1
911     (defmethod output-record-start-cursor-position ((record text-displayed-output-record))
912     (with-slots (start-x start-y) record
913     (values start-x start-y)))
914    
915     (defmethod output-record-end-cursor-position ((record text-displayed-output-record))
916     (with-slots (end-x end-y) record
917     (values end-x end-y)))
918    
919     (defmethod text-displayed-output-record-string ((record text-displayed-output-record))
920     (with-slots (strings) record
921     (loop for result = ""
922     for s in strings
923     do (setq result (concatenate 'string result (third s)))
924     finally (return result))))
925 cvs 1.5
926    
927 adejneka 1.21 ;;; Methods for text output to output recording streams
928 adejneka 1.22 (defmethod stream-text-output-record ((stream standard-output-recording-stream) text-style)
929 adejneka 1.20 (let ((record (stream-current-text-output-record stream)))
930     (unless record
931     (setf (stream-current-text-output-record stream)
932     (setq record (make-instance 'text-displayed-output-record)))
933 adejneka 1.22 (with-slots (start-x start-y end-x end-y x1 y1 x2 y2 x y
934 adejneka 1.20 initial-x1 initial-y1) record
935 cvs 1.8 (multiple-value-bind (cx cy) (stream-cursor-position stream)
936 adejneka 1.22 (setq start-x cx
937     start-y cy
938 cvs 1.8 end-x start-x
939 cvs 1.9 end-y start-y
940 adejneka 1.22 x1 (coordinate start-x)
941     x2 (coordinate end-x)
942     y1 (coordinate start-y)
943     y2 (coordinate end-y)
944 adejneka 1.20 initial-x1 x1
945 adejneka 1.22 initial-y1 y1
946     x start-x
947     y start-y))))
948 adejneka 1.20 record))
949    
950 adejneka 1.22 (defmethod stream-close-text-output-record ((stream standard-output-recording-stream))
951 adejneka 1.20 (let ((record (stream-current-text-output-record stream)))
952     (when record
953     (setf (stream-current-text-output-record stream) nil)
954     #|record stream-current-cursor-position to (end-x record) - already done|#
955     (stream-add-output-record stream record))))
956    
957 adejneka 1.22 (defmethod stream-add-character-output ((stream standard-output-recording-stream)
958 adejneka 1.20 character text-style
959     width height baseline)
960     (add-character-output-to-text-record (stream-text-output-record stream text-style)
961     character text-style width height baseline))
962    
963 adejneka 1.22 (defmethod stream-add-string-output ((stream standard-output-recording-stream)
964 adejneka 1.20 string start end text-style
965     width height baseline)
966     (add-string-output-to-text-record (stream-text-output-record stream text-style)
967     string start end text-style
968     width height baseline))
969    
970     (defmacro without-local-recording (stream &body body)
971 adejneka 1.22 `(letf (((slot-value ,stream 'local-record-p) nil))
972     ,@body))
973    
974     (defmethod stream-write-line :around ((stream standard-output-recording-stream) line)
975     (when (and (stream-recording-p stream)
976     (slot-value stream 'local-record-p))
977     (let* ((medium (sheet-medium stream))
978     (text-style (medium-text-style medium))
979     (port (port stream)))
980     (stream-add-string-output stream line 0 nil text-style
981     (stream-string-width stream line
982     :text-style text-style)
983     (text-style-height text-style port)
984     (text-style-ascent text-style port))))
985     (when (stream-drawing-p stream)
986     (without-local-recording stream
987     (call-next-method))))
988 cvs 1.5
989 adejneka 1.22 #+nil
990     (defmethod stream-write-char :around ((stream standard-output-recording-stream) char)
991 adejneka 1.20 (when (and (stream-recording-p stream)
992     (slot-value stream 'local-record-p))
993     (if (or (eql char #\return)
994     (eql char #\newline))
995     (stream-close-text-output-record stream)
996 cvs 1.8 (let* ((medium (sheet-medium stream))
997 adejneka 1.20 (text-style (medium-text-style medium))
998     (port (port stream)))
999     (stream-add-character-output stream char text-style
1000     (stream-character-width stream char :text-style text-style)
1001     (text-style-height text-style port)
1002     (text-style-ascent text-style port)))))
1003     (without-local-recording stream
1004     (call-next-method)))
1005    
1006 adejneka 1.21 #+nil
1007 adejneka 1.22 (defmethod stream-write-string :around ((stream standard-output-recording-stream) string
1008 adejneka 1.20 &optional (start 0) end)
1009 adejneka 1.21 ;; Problem: it is necessary to check for line wrapping. Now the
1010     ;; default method for STREAM-WRITE-STRING do char-by-char output,
1011     ;; therefore STREAM-WRITE-CHAR can do the right thing.
1012 adejneka 1.20 (when (and (stream-recording-p stream)
1013     (slot-value stream 'local-record-p))
1014     (let* ((medium (sheet-medium stream))
1015     (text-style (medium-text-style medium))
1016     (port (port stream)))
1017     (stream-add-string-output stream string start end text-style
1018     (stream-string-width stream string
1019     :start start :end end
1020     :text-style text-style)
1021     (text-style-height text-style port)
1022     (text-style-ascent text-style port))))
1023     (without-local-recording stream
1024     (call-next-method)))
1025    
1026    
1027 adejneka 1.22 (defmethod stream-finish-output :after ((stream standard-output-recording-stream))
1028 adejneka 1.20 (stream-close-text-output-record stream))
1029    
1030 adejneka 1.22 (defmethod stream-force-output :after ((stream standard-output-recording-stream))
1031 adejneka 1.20 (stream-close-text-output-record stream))
1032    
1033 adejneka 1.22 (defmethod stream-terpri :after ((stream standard-output-recording-stream))
1034 adejneka 1.21 (stream-close-text-output-record stream))
1035    
1036 rouanet 1.23 (defmethod* (setf stream-cursor-position) :after (x y (stream standard-output-recording-stream))
1037 adejneka 1.20 (stream-close-text-output-record stream))
1038    
1039 adejneka 1.22 ;(defmethod stream-set-cursor-position :after ((stream standard-output-recording-stream))
1040 adejneka 1.20 ; (stream-close-text-output-record stream))
1041 cvs 1.5
1042 adejneka 1.22 (defmethod stream-wrap-line :before ((stream standard-output-recording-stream))
1043 cvs 1.5 (when (stream-recording-p stream)
1044 adejneka 1.20 (setf (text-record-wrapped (stream-text-output-record stream nil)) ; FIXME!
1045     (stream-text-margin stream))))

  ViewVC Help
Powered by ViewVC 1.1.5