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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.38 - (hide annotations)
Sun Apr 28 11:17:07 2002 UTC (11 years, 11 months ago) by gilbert
Branch: MAIN
Changes since 1.37: +1 -4 lines
Besides some support for enabled/disabled sheets in panes.lisp and removal
of some unused code, the most notable change is:

- removal of all method defintions like
  (defmethod handle-event ((foo foo-pane) (event window-repaint-event))
    (repaint-sheet foo (event-region event))

- Switched last remaining REPAINT-SHEET methods into HANDLE-REPAINT, since
  HANDLE-REPAINT is where you define repainting. REPAINT-SHEET is for forcing
  a repaint not for implementing a repaint. [Although I am German my reading
  comprehension should be just good enough to understand the relevant chapter
  of the specification].
  This breaks CLIM-FIG again, refer to my posting to the mailing list.
1 mikemac 1.1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2    
3 mikemac 1.29 ;;; (c) copyright 1998,1999,2000,2001 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 mikemac 1.1 (in-package :CLIM-INTERNALS)
36    
37 moore 1.34 ;;; Should we blow off standard-bounding-rectangle and implement the
38     ;;; bounding rectangle protocol ourselves? Or use x1,y1 from
39     ;;; standard-bounding-rectangle as our position?
40    
41     (defclass basic-output-record (bounding-rectangle)
42     ()
43     (:documentation "Internal protocol class for common elements of output-record
44     and displayed-output-record"))
45    
46     (defclass basic-output-record-mixin (standard-bounding-rectangle
47     basic-output-record)
48 mikemac 1.1 ((x :initarg :x-position
49 adejneka 1.22 :initform 0
50     :type rational)
51 mikemac 1.1 (y :initarg :y-position
52 adejneka 1.22 :initform 0
53     :type rational)
54 mikemac 1.1 (parent :initarg :parent
55 rouanet 1.11 :initform nil
56 moore 1.34 :reader output-record-parent))
57     (:documentation "Implementation class for the Basic Output Record Protocol"))
58 rouanet 1.11
59 moore 1.34 (defmethod initialize-instance :after ((record basic-output-record-mixin)
60     &rest args)
61 rouanet 1.13 (declare (ignore args))
62 moore 1.34 (with-slots (x y x1 y1 x2 y2) record
63     (setq x1 x
64     y1 y
65     x2 x
66     y2 y)))
67    
68     (defclass output-record (basic-output-record)
69     ())
70    
71     (defun output-record-p (x)
72     (typep x 'output-record))
73 rouanet 1.11
74 moore 1.34 (defclass output-record-mixin (basic-output-record-mixin output-record)
75 rouanet 1.11 ((children :initform nil
76     :reader output-record-children))
77 moore 1.34 (:documentation "Implementation class for output records i.e., those records
78     that have children."))
79 mikemac 1.1
80 moore 1.34 (defclass displayed-output-record (basic-output-record)
81     ())
82 mikemac 1.1
83 moore 1.34 (defclass displayed-output-record-mixin (basic-output-record-mixin
84     displayed-output-record)
85 rouanet 1.18 ((ink :initarg :ink :reader displayed-output-record-ink)
86     (initial-x1 :initarg :initial-x1)
87 moore 1.34 (initial-y1 :initarg :initial-y1))
88     (:documentation "Implementation class for displayed-output-record."))
89 mikemac 1.1
90     (defun displayed-output-record-p (x)
91     (typep x 'displayed-output-record))
92    
93 adejneka 1.21 ; 16.2.1. The Basic Output Record Protocol
94 mikemac 1.30 #+:cmu(declaim (ftype (function (output-record) (values rational rational))
95     output-record-position))
96 adejneka 1.22 (defgeneric output-record-position (record)
97     (:documentation
98     "Returns the x and y position of RECORD. The position is the
99     position of the upper-left corner of its bounding rectangle. The
100     position is relative to the stream, where (0,0) is (initially) the
101     upper-left corner of the stream."))
102    
103 rouanet 1.23 (defgeneric* (setf output-record-position) (x y record))
104 adejneka 1.22
105 mikemac 1.30 #+:cmu(declaim (ftype (function (output-record) (values integer integer))
106     output-record-start-cursor-position))
107 adejneka 1.22 (defgeneric output-record-start-cursor-position (record)
108     (:documentation
109     "Returns the x and y starting cursor position of RECORD. The
110     positions are relative to the stream, where (0,0) is (initially) the
111     upper-left corner of the stream."))
112    
113 rouanet 1.23 (defgeneric* (setf output-record-start-cursor-position) (x y record))
114 adejneka 1.22
115 mikemac 1.30 #+:cmu(declaim (ftype (function (output-record) (values integer integer))
116     output-record-end-cursor-position))
117 adejneka 1.22 (defgeneric output-record-end-cursor-position (record)
118     (:documentation
119     "Returns the x and y ending cursor position of RECORD. The
120     positions are 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-end-cursor-position) (x y record))
124 adejneka 1.22
125     (defgeneric output-record-parent (record)
126     (:documentation
127     "Returns the output record that is the parent of RECORD, or nil if
128     RECORD has no parent."))
129    
130 adejneka 1.21 (defgeneric replay-output-record (record stream
131 adejneka 1.22 &optional region x-offset y-offset)
132     (:documentation "Displays the output captured by RECORD on the
133     STREAM, exactly as it was originally captured. The current user
134     transformation, line style, text style, ink and clipping region of
135     STREAM are all ignored. Instead, these are gotten from the output
136     record.
137    
138     Only those records that overlap REGION are displayed."))
139    
140 adejneka 1.21 (defgeneric output-record-hit-detection-rectangle* (record))
141 adejneka 1.22
142 adejneka 1.21 (defgeneric output-record-refined-position-test (record x y))
143 adejneka 1.22
144 adejneka 1.21 (defgeneric highlight-output-record (record stream state))
145 adejneka 1.22
146 adejneka 1.21 (defgeneric displayed-output-record-ink (displayed-output-record))
147    
148     ; 16.2.2. Output Record "Database" Protocol
149 adejneka 1.22
150 adejneka 1.21 (defgeneric output-record-children (record))
151 adejneka 1.22
152 adejneka 1.21 (defgeneric add-output-record (child record))
153 adejneka 1.22
154 adejneka 1.21 (defgeneric delete-output-record (child record &optional (errorp t)))
155 adejneka 1.22
156 adejneka 1.21 (defgeneric clear-output-record (record))
157 adejneka 1.22
158 adejneka 1.21 (defgeneric output-record-count (record))
159 adejneka 1.22
160 adejneka 1.21 (defgeneric map-over-output-records-containing-position
161     (function record x y &optional x-offset y-offset &rest function-args))
162 adejneka 1.22
163 adejneka 1.21 (defgeneric map-over-output-records-overlapping-region
164     (function record region &optional x-offset y-offset &rest function-args))
165    
166 moore 1.34 ;;; From the Franz CLIM user's guide but not in the spec... clearly necessary.
167     (defgeneric map-over-output-records
168     (continuation record &optional x-offset y-offset &rest continuation-args))
169    
170 adejneka 1.21 ; 16.2.3. Output Record Change Notification Protocol
171 adejneka 1.22
172 adejneka 1.21 (defgeneric recompute-extent-for-new-child (record child))
173 adejneka 1.22
174 adejneka 1.21 (defgeneric recompute-extent-for-changed-child
175     (record child old-min-x old-min-y old-max-x old-max-y))
176 adejneka 1.22
177 adejneka 1.21 (defgeneric tree-recompute-extent (record))
178    
179     ;;; Methods
180 adejneka 1.22
181 moore 1.34 (defmethod output-record-position ((record basic-output-record-mixin))
182 mikemac 1.1 (with-slots (x y) record
183     (values x y)))
184    
185 moore 1.34 (defvar *suppress-notify-parent* nil
186     "When t, don't notify the parent of a change in an output record's
187     bounding rectangle.")
188    
189     (defmethod* (setf output-record-position)
190     (nx ny (record basic-output-record-mixin))
191 rouanet 1.18 (with-slots (x y x1 y1 x2 y2) record
192     (let ((dx (- nx x))
193     (dy (- ny y)))
194     (incf x1 dx) (incf y1 dy)
195     (incf x2 dx) (incf y2 dy))
196     (setq x nx
197     y ny)))
198 mikemac 1.1
199 moore 1.34 (defmethod* (setf output-record-position) :before
200     (nx ny (record output-record))
201     (let ((*suppress-notify-parent* t))
202     (multiple-value-bind (old-x old-y) (output-record-position record)
203     (loop with dx = (- nx old-x)
204     and dy = (- ny old-y)
205     for child in (output-record-children record)
206     do (multiple-value-bind (x y) (output-record-position child)
207     (setf (output-record-position child)
208     (values (+ x dx) (+ y dy))))))))
209    
210 rouanet 1.11
211 moore 1.34 (defmethod* (setf output-record-position) :around
212     (nx ny (record basic-output-record))
213 rouanet 1.11 (declare (ignore nx ny))
214 moore 1.34 (if *suppress-notify-parent*
215     (call-next-method)
216     (with-bounding-rectangle* (min-x min-y max-x max-y) record
217     (call-next-method)
218     (let ((parent (output-record-parent record)))
219     (when parent
220     (recompute-extent-for-changed-child parent record
221     min-x min-y max-x max-y))))))
222    
223 rouanet 1.11
224 moore 1.34 (defmethod output-record-start-cursor-position ((record basic-output-record))
225 mikemac 1.1 (values nil nil))
226    
227 moore 1.34 (defmethod* (setf output-record-start-cursor-position)
228     (x y (record basic-output-record))
229 mikemac 1.1 (declare (ignore x y))
230     nil)
231    
232 moore 1.34 (defmethod output-record-end-cursor-position ((record basic-output-record))
233 mikemac 1.1 (values nil nil))
234    
235 moore 1.34 (defmethod* (setf output-record-end-cursor-position)
236     (x y (record basic-output-record))
237 mikemac 1.1 (declare (ignore x y))
238     nil)
239    
240 adejneka 1.24 (defun replay (record stream &optional region)
241 adejneka 1.21 (stream-close-text-output-record stream)
242 rouanet 1.11 (when (stream-drawing-p stream)
243 adejneka 1.22 (with-cursor-off stream
244     (multiple-value-bind (cx cy) (stream-cursor-position stream)
245     (unwind-protect
246     (letf (((stream-recording-p stream) nil))
247     (replay-output-record record stream region))
248 rouanet 1.23 (setf (stream-cursor-position stream) (values cx cy)))))))
249 mikemac 1.1
250     (defmethod replay-output-record ((record output-record) stream
251 rouanet 1.18 &optional region (x-offset 0) (y-offset 0))
252 rouanet 1.11 (when (null region)
253     (setq region +everywhere+))
254 moore 1.34 (map-over-output-records-overlapping-region
255 rouanet 1.11 #'replay-output-record record region x-offset y-offset
256     stream region x-offset y-offset))
257 mikemac 1.1
258 moore 1.34 ;;; XXX ? should this be defined on output-record at all?
259     ;;; Probably not -- moore
260 adejneka 1.21 (defmethod erase-output-record ((record output-record) stream &optional (errorp t))
261 mikemac 1.30 (declare (ignore stream errorp))
262 mikemac 1.1 nil)
263    
264 moore 1.34 (defmethod output-record-hit-detection-rectangle*
265     ((record basic-output-record))
266 mikemac 1.1 (bounding-rectangle* record))
267    
268 moore 1.34 (defmethod output-record-refined-sensitivity-test ((record basic-output-record) x y)
269 rouanet 1.13 (declare (ignore x y))
270     t)
271 mikemac 1.1
272 moore 1.34 ;;; XXX Should this only be defined on recording streams?
273     (defmethod highlight-output-record ((record basic-output-record-mixin)
274     stream state)
275 mikemac 1.1 (multiple-value-bind (x1 y1 x2 y2) (output-record-hit-detection-rectangle* record)
276     (ecase state
277     (:highlight
278 rouanet 1.11 (draw-rectangle* (sheet-medium stream) x1 y1 x2 y2 :filled nil :ink +foreground-ink+))
279 mikemac 1.1 (:unhighlight
280 rouanet 1.11 (draw-rectangle* (sheet-medium stream) x1 y1 x2 y2 :filled nil :ink +background-ink+)))))
281    
282 moore 1.34 (defclass standard-sequence-output-record (output-record-mixin)
283 rouanet 1.11 (
284     ))
285    
286 moore 1.34 (defclass standard-tree-output-record (output-record-mixin)
287 rouanet 1.11 (
288     ))
289    
290 moore 1.34 #+nil
291 rouanet 1.23 (defmethod* (setf output-record-position) (nx ny (record standard-sequence-output-record))
292 adejneka 1.21 (with-slots (x y) record
293 rouanet 1.23 (setq x nx
294     y ny)))
295 adejneka 1.21
296 moore 1.34 (defmethod output-record-children ((output-record output-record-mixin))
297 rouanet 1.11 (with-slots (children) output-record
298     (reverse children)))
299 mikemac 1.1
300 moore 1.34 (defmethod add-output-record (child (record output-record-mixin))
301 mikemac 1.1 (with-slots (children) record
302     (push child children))
303     (with-slots (parent) child
304     (setf parent record)))
305    
306 moore 1.34 (defmethod add-output-record :before (child (record output-record-mixin))
307 rouanet 1.11 (when (null (output-record-children record))
308     (with-slots (x1 y1 x2 y2) record
309 strandh 1.37 (setf (values x1 y1 x2 y2) (bounding-rectangle* child)))))
310 rouanet 1.11
311     (defmethod add-output-record :after (child (record output-record))
312     (recompute-extent-for-new-child record child))
313    
314 moore 1.34 (defmethod delete-output-record (child (record output-record-mixin)
315     &optional (errorp t))
316 mikemac 1.1 (with-slots (children) record
317     (if (and errorp
318     (not (member child children)))
319     (error "~S is not a child of ~S" child record))
320     (setq children (delete child children))))
321    
322 moore 1.34 (defmethod delete-output-record :after (child (record output-record-mixin)
323     &optional (errorp t))
324 rouanet 1.11 (declare (ignore errorp))
325     (with-bounding-rectangle* (x1 y1 x2 y2) child
326     (recompute-extent-for-changed-child record child x1 y1 x2 y2)))
327    
328 moore 1.34 (defmethod clear-output-record ((record output-record-mixin))
329 cvs 1.3 (with-slots (children x1 y1 x2 y2) record
330 mikemac 1.1 (setq children nil
331 moore 1.34 x2 x1
332     y2 y1)))
333 mikemac 1.1
334 moore 1.34 (defmethod output-record-count ((record output-record-mixin))
335 mikemac 1.1 (length (output-record-children record)))
336    
337 moore 1.35 (defmethod output-record-count ((record output-record))
338     (let ((count 0))
339     (map-over-output-records #'(lambda (record)
340     (declare (ignore record))
341     (incf count))
342     record)
343     count))
344    
345 moore 1.34 (defmethod map-over-output-records (function (record output-record-mixin)
346     &optional (x-offset 0) (y-offset 0)
347     &rest function-args)
348 moore 1.36 (declare (ignore x-offset y-offset))
349 moore 1.34 (loop for child in (output-record-children record)
350     do (apply function child function-args)))
351    
352 moore 1.35 ;; Applies if there isn't a more specific method
353     (defmethod map-over-output-records-containing-position
354     (function (record output-record) x y
355     &optional (x-offset 0) (y-offset 0)
356     &rest function-args)
357     (declare (ignore x-offset y-offset))
358     (flet ((mapper (child)
359     (multiple-value-bind (min-x min-y max-x max-y)
360     (output-record-hit-detection-rectangle* child)
361     (when (and (<= min-x x max-x)
362     (<= min-y y max-y)
363     (output-record-refined-sensitivity-test child
364     x y))
365     (apply function child function-args)))))
366 moore 1.36 (declare (dynamic-extent #'mapper))
367 moore 1.35 (map-over-output-records #'mapper record)))
368    
369     (defmethod map-over-output-records-containing-position
370     (function (record output-record-mixin) x y
371     &optional (x-offset 0) (y-offset 0)
372     &rest function-args)
373 moore 1.36 (declare (ignore x-offset y-offset))
374 mikemac 1.1 (loop for child in (output-record-children record)
375 moore 1.34 when (and (multiple-value-bind (min-x min-y max-x max-y)
376     (output-record-hit-detection-rectangle* child)
377     (and (<= min-x x max-x) (<= min-y y max-y)))
378 rouanet 1.13 (output-record-refined-sensitivity-test child x y))
379     do (apply function child function-args)))
380 mikemac 1.1
381 moore 1.35 (defmethod map-over-output-records-overlapping-region
382     (function (record output-record) region
383     &optional (x-offset 0) (y-offset 0)
384     &rest function-args)
385     (declare (ignore x-offset y-offset))
386     (flet ((mapper (child)
387     (when (region-intersects-region-p region child)
388     (apply function child function-args))))
389 moore 1.36 (declare (dynamic-extent #'mapper))
390 moore 1.35 (map-over-output-records #'mapper record)))
391    
392 moore 1.34 (defmethod map-over-output-records-overlapping-region (function (record output-record) region
393 rouanet 1.11 &optional (x-offset 0) (y-offset 0)
394     &rest function-args)
395 moore 1.36 (declare (ignore x-offset y-offset))
396 rouanet 1.11 (loop for child in (output-record-children record)
397     do (when (region-intersects-region-p region child)
398     (apply function child function-args))))
399 mikemac 1.1
400 moore 1.34 ;;; If the child is the only child of record, the record's bounding rectangle
401     ;;; is set to the child's.
402     (defmethod recompute-extent-for-new-child ((record output-record-mixin) child)
403 rouanet 1.11 (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2) record
404 moore 1.34 (with-slots (parent children x1 y1 x2 y2) record
405     (if (null (cdr children))
406     (setf (values x1 y1 x2 y2) (bounding-rectangle* child))
407     (with-bounding-rectangle* (x1-child y1-child x2-child y2-child) child
408     (minf x1 x1-child)
409     (minf y1 y1-child)
410     (maxf x2 x2-child)
411     (maxf y2 y2-child)))
412 rouanet 1.11 (when parent
413 moore 1.34 (recompute-extent-for-changed-child parent record
414     old-x1 old-y1 old-x2 old-y2)))))
415 mikemac 1.1
416 moore 1.34 (defmethod recompute-extent-for-changed-child :around
417     ((record basic-output-record-mixin) child
418     old-min-x old-min-y old-max-x old-max-y)
419 rouanet 1.11 (declare (ignore child old-min-x old-min-y old-max-x old-max-y))
420     (let ((old-rectangle (multiple-value-call #'make-bounding-rectangle
421     (bounding-rectangle* record))))
422     (call-next-method)
423     (with-slots (parent x1 y1 x2 y2) record
424 adejneka 1.21 (when (and parent (not (region-equal old-rectangle record)))
425 rouanet 1.11 (recompute-extent-for-changed-child parent record x1 y1 x2 y2)))))
426    
427 moore 1.34 ;; Internal helper function
428     (defmethod %tree-recompute-extent* ((record output-record))
429     (let ((new-x1 0)
430     (new-y1 0)
431     (new-x2 0)
432     (new-y2 0)
433     (first-time t))
434     (map-over-output-records
435     #'(lambda (child)
436     (if first-time
437     (progn
438     (setf (values new-x1 new-y1 new-x2 new-y2)
439     (bounding-rectangle* child))
440     (setq first-time nil))
441     (with-bounding-rectangle* (cx1 cy1 cx2 cy2) child
442     (minf new-x1 cx1)
443     (minf new-y1 cy1)
444     (maxf new-x2 cx2)
445     (maxf new-y2 cy2))))
446     record)
447     ;; If we don't have any children, collapse the bbox to the min point.
448     (if first-time
449 moore 1.36 (multiple-value-bind (x1 y1)
450     (output-record-position record)
451 moore 1.34 (values x1 y1 x1 y1))
452     (values new-x1 new-y1 new-x2 new-y2))))
453    
454     (defmethod recompute-extent-for-changed-child
455     ((record output-record-mixin) changed-child
456     old-min-x old-min-y old-max-x old-max-y)
457     ;; If the child's old and new bbox lies entirely within the record's bbox
458     ;; then no change need be made to the record's bbox. Otherwise, if some part
459     ;; of the child's bbox was on the record's bbox and is now inside, examine
460     ;; all the children to determine the correct new bbox.
461     (with-slots (x1 y1 x2 y2) record
462     (with-bounding-rectangle* (child-x1 child-y1 child-x2 child-y2)
463     changed-child
464     (unless (and (> x1 old-min-x)
465     (> y1 old-min-y)
466     (< x2 old-max-x)
467     (< y2 old-max-y)
468     (> x1 child-x1)
469     (> y1 child-y1)
470     (< x2 child-x2)
471     (< y2 child-y2))
472     ;; Don't know if changed-child has been deleted or what, so go through
473     ;; all the children and construct the updated bbox.
474     (setf (values x1 y1 x2 y2) (%tree-recompute-extent* record))
475     nil))))
476    
477     (defmethod tree-recompute-extent ((record output-record-mixin))
478     (with-slots (x1 y1 x2 y2) record
479     (setf (values x1 y1 x2 y2) (%tree-recompute-extent* record))
480     nil))
481 mikemac 1.1
482 adejneka 1.22
483     (defmethod tree-recompute-extent :around ((record output-record))
484     (let ((old-rectangle (multiple-value-call #'make-bounding-rectangle
485     (bounding-rectangle* record))))
486     (call-next-method)
487     (with-slots (parent x1 y1 x2 y2) record
488     (when (and parent (not (region-equal old-rectangle record)))
489     (recompute-extent-for-changed-child parent record x1 y1 x2 y2)))))
490 mikemac 1.1
491    
492     ;;; Graphics recording classes
493    
494     (defclass graphics-displayed-output-record (displayed-output-record)
495 moore 1.34 ())
496    
497     (defclass graphics-displayed-output-record-mixin
498     (displayed-output-record-mixin graphics-displayed-output-record)
499 adejneka 1.14 ((clip :initarg :clipping-region
500     :documentation "Clipping region in user coordinates.")
501 mikemac 1.1 (transform :initarg :transformation)
502     (line-style :initarg :line-style)
503     (text-style :initarg :text-style)
504     ))
505    
506     (defun graphics-displayed-output-record-p (x)
507     (typep x 'graphics-displayed-output-record))
508    
509    
510     ;;; stream-output-history-mixin class
511    
512     (defclass stream-output-history-mixin ()
513 rouanet 1.11 ())
514    
515     (defclass standard-sequence-output-history (standard-sequence-output-record stream-output-history-mixin)
516     ())
517    
518     (defclass standard-tree-output-history (standard-tree-output-record stream-output-history-mixin)
519     ())
520    
521    
522     ;;; Output-Recording-Stream class
523    
524     (defclass output-recording-stream ()
525 moore 1.34 ())
526    
527     (defun output-recording-stream-p (x)
528     (typep x 'output-recording-stream))
529    
530     (defclass standard-output-recording-stream (output-recording-stream)
531     ((recording-p :initform t :reader stream-recording-p)
532 rouanet 1.11 (drawing-p :initform t :accessor stream-drawing-p)
533     (output-history :initform (make-instance 'standard-tree-output-history)
534     :reader stream-output-history)
535 adejneka 1.20 (current-output-record :accessor stream-current-output-record)
536     (current-text-output-record :initform nil :accessor stream-current-text-output-record)
537     (local-record-p :initform t
538     :documentation "This flag is used for dealing with streams outputting strings char-by-char.")))
539 rouanet 1.11
540 adejneka 1.21 ;;; 16.4.1 The Output Recording Stream Protocol
541     (defgeneric stream-recording-p (stream))
542 adejneka 1.22
543 adejneka 1.21 (defgeneric (setf stream-recording-p) (recording-p stream))
544 adejneka 1.22
545 adejneka 1.21 (defgeneric stream-drawing-p (stream))
546 adejneka 1.22
547 adejneka 1.21 (defgeneric (setf stream-drawing-p) (drawing-p stream))
548 adejneka 1.22
549 adejneka 1.21 (defgeneric stream-output-history (stream))
550 adejneka 1.22
551 adejneka 1.21 (defgeneric stream-current-output-record (stream))
552 adejneka 1.22
553 adejneka 1.21 (defgeneric (setf stream-current-output-record) (record stream))
554 adejneka 1.22
555 adejneka 1.21 (defgeneric stream-add-output-record (stream record))
556 adejneka 1.22
557 adejneka 1.21 (defgeneric stream-replay (stream &optional region))
558 adejneka 1.22
559 adejneka 1.21 (defgeneric erase-output-record (record stream &optional (errorp t)))
560 adejneka 1.22
561 adejneka 1.21 (defgeneric copy-textual-output-history (window stream &optional region record))
562    
563 moore 1.34 (defmethod (setf stream-recording-p)
564     (recording-p (stream standard-output-recording-stream))
565     (let ((old-val (slot-value stream 'recording-p)))
566     (setf (slot-value stream 'recording-p) recording-p)
567     (when (not (eql old-val recording-p))
568     (stream-close-text-output-record stream))
569     recording-p))
570    
571 adejneka 1.21 ;;; 16.4.3 Text Output Recording
572 adejneka 1.22
573 adejneka 1.21 (defgeneric stream-text-output-record (stream text-style))
574 adejneka 1.22
575 adejneka 1.21 (defgeneric stream-close-text-output-record (stream))
576 adejneka 1.22
577 adejneka 1.21 (defgeneric stream-add-character-output
578     (stream character text-style width height baseline))
579 adejneka 1.22
580 adejneka 1.21 (defgeneric stream-add-string-output
581     (stream string start end text-style width height baseline))
582    
583     ;;; Methods
584 rouanet 1.11 (defmethod initialize-instance :after ((stream output-recording-stream) &rest args)
585     (declare (ignore args))
586     (setf (stream-current-output-record stream) (stream-output-history stream)))
587    
588     (defmethod stream-add-output-record ((stream output-recording-stream) record)
589 adejneka 1.16 (add-output-record record (stream-current-output-record stream)))
590 rouanet 1.11
591     (defmethod stream-replay ((stream output-recording-stream) &optional region)
592     (replay (stream-output-history stream) stream region))
593    
594 moore 1.34 (defmacro with-output-recording-options ((stream
595     &key (record nil record-supplied-p)
596     (draw nil draw-supplied-p))
597     &body body)
598 adejneka 1.16 (declare (type symbol stream))
599     (when (eq stream 't)
600 rouanet 1.18 (setq stream '*standard-output*))
601 moore 1.34 (let ((continuation-name (gensym "WITH-OUTPUT-RECORDING-OPTIONS")))
602     `(flet ((,continuation-name (,stream) ,@body))
603 moore 1.36 (declare (dynamic-extent #',continuation-name))
604 adejneka 1.16 (invoke-with-output-recording-options ,stream
605 moore 1.34 #',continuation-name
606     ,(if record-supplied-p
607     record
608     `(stream-recording-p
609     ,stream))
610     ,(if draw-supplied-p
611     draw
612     `(stream-drawing-p
613     ,stream))))))
614    
615 adejneka 1.16
616     (defmethod invoke-with-output-recording-options
617     ((stream output-recording-stream) continuation record draw)
618     "Calls CONTINUATION on STREAM enabling or disabling recording and drawing
619     according to the flags RECORD and DRAW."
620 moore 1.34 (letf (((stream-recording-p stream) record)
621     ((stream-drawing-p stream) draw))
622     (funcall continuation stream)))
623 adejneka 1.16
624     (defmacro with-new-output-record ((stream
625     &optional
626 rouanet 1.18 (record-type 'standard-sequence-output-record)
627 adejneka 1.16 (record nil record-supplied-p)
628     &rest initargs)
629     &body body)
630     "Creates a new output record of type RECORD-TYPE and then captures
631     the output of BODY into the new output record, and inserts the new
632     record into the current \"open\" output record assotiated with STREAM.
633     If RECORD is supplied, it is the name of a variable that will be
634     lexically bound to the new output record inside the body. INITARGS are
635     CLOS initargs that are passed to MAKE-INSTANCE when the new output
636     record is created.
637     It returns the created output record.
638     The STREAM argument is a symbol that is bound to an output
639     recording stream. If it is T, *STANDARD-OUTPUT* is used."
640     (declare (type symbol stream record))
641     (when (eq stream 't)
642     (setq stream '*standard-output*))
643     (unless record-supplied-p
644     (setq record (gensym)))
645     `(invoke-with-new-output-record
646     ,stream
647     #'(lambda (,stream ,record)
648 adejneka 1.19 ,@(unless record-supplied-p `((declare (ignore ,record))))
649 adejneka 1.16 ,@body)
650 rouanet 1.18 ',record-type
651 adejneka 1.16 ,@initargs))
652    
653     (defmethod invoke-with-new-output-record ((stream output-recording-stream)
654     continuation record-type
655     &rest initargs
656 moore 1.31 &key parent
657     &allow-other-keys)
658 adejneka 1.20 (stream-close-text-output-record stream)
659 adejneka 1.16 (unless parent
660     (setq parent (stream-current-output-record stream)))
661 adejneka 1.22 (let ((new-record (apply #'make-instance record-type :parent parent initargs)))
662     (letf (((stream-current-output-record stream) new-record))
663     (funcall continuation stream new-record)
664     (finish-output stream))
665     (stream-add-output-record stream new-record)
666 adejneka 1.16 new-record))
667 cvs 1.10
668 rouanet 1.11 (defmethod scroll-vertical :around ((stream output-recording-stream) dy)
669 mikemac 1.1 (declare (ignore dy))
670     (with-output-recording-options (stream :record nil)
671     (call-next-method)))
672    
673 rouanet 1.11 (defmethod scroll-horizontal :around ((stream output-recording-stream) dx)
674 mikemac 1.1 (declare (ignore dx))
675     (with-output-recording-options (stream :record nil)
676     (call-next-method)))
677    
678 gilbert 1.38 (defmethod handle-repaint ((stream output-recording-stream) region)
679 rouanet 1.11 (stream-replay stream region))
680 cvs 1.7
681 rouanet 1.11 #|
682     (defmethod handle-event :after ((stream output-recording-stream) (event pointer-button-press-event))
683 rouanet 1.18 (highlight-output-record (stream-current-output-record stream) stream :highlight))
684 rouanet 1.11
685     (defmethod handle-event :before ((stream output-recording-stream) (event pointer-button-release-event))
686 rouanet 1.18 (highlight-output-record (stream-current-output-record stream) stream :unhighlight))
687 rouanet 1.11 |#
688 mikemac 1.1
689    
690 adejneka 1.21 ;;; Graphics and text recording classes
691 mikemac 1.1
692 moore 1.34 (eval-when (:compile-toplevel :load-toplevel :execute)
693 mikemac 1.1
694     (defun compute-class-vars (names)
695     (cons (list 'stream :initarg :stream)
696     (loop for name in names
697 cvs 1.2 collecting (list name :initarg (intern (symbol-name name) :keyword)))))
698 mikemac 1.1
699     (defun compute-arg-list (names)
700     (loop for name in names
701 cvs 1.2 nconcing (list (intern (symbol-name name) :keyword) name)))
702 mikemac 1.1 )
703    
704     (defun make-merged-medium (sheet ink clip transform line-style text-style)
705     (let ((medium (make-medium (port sheet) sheet)))
706     (setf (medium-ink medium) ink)
707 adejneka 1.14 ;; First set transformation, then clipping region!
708     (setf (medium-transformation medium) transform)
709 mikemac 1.1 (setf (medium-clipping-region medium) clip)
710     (setf (medium-line-style medium) line-style)
711     (setf (medium-text-style medium) text-style)
712     medium))
713    
714     (defmacro def-grecording (name (&rest args) &body body)
715     (let ((method-name (intern (format nil "MEDIUM-~A*" name)))
716     (class-name (intern (format nil "~A-OUTPUT-RECORD" name)))
717     (old-medium (gensym))
718 rouanet 1.12 (new-medium (gensym))
719     (border (gensym)))
720 cvs 1.10 `(progn
721 moore 1.34 (defclass ,class-name (graphics-displayed-output-record-mixin)
722 mikemac 1.1 ,(compute-class-vars args))
723     (defmethod initialize-instance :after ((graphic ,class-name) &rest args)
724     (declare (ignore args))
725 rouanet 1.18 (with-slots (x y x1 y1 x2 y2 initial-x1 initial-y1
726 adejneka 1.14 stream ink clipping-region transform
727 mikemac 1.1 line-style text-style
728     ,@args) graphic
729 rouanet 1.12 (let ((,border (1+ (/ (line-style-thickness line-style) 2))))
730     (multiple-value-bind (lf tp rt bt) (progn ,@body)
731     (setq x1 (- lf ,border)
732     y1 (- tp ,border)
733     x2 (+ rt ,border)
734 rouanet 1.18 y2 (+ bt ,border))))
735     (setf x x1
736     y y1
737     initial-x1 x1
738     initial-y1 y1)))
739 rouanet 1.11 (defmethod ,method-name :around ((stream output-recording-stream) ,@args)
740 mikemac 1.1 (with-sheet-medium (medium stream)
741 cvs 1.5 (when (stream-recording-p stream)
742     (let ((record (make-instance ',class-name
743     :stream stream
744     :ink (medium-ink medium)
745     :clipping-region (medium-clipping-region medium)
746     :transformation (medium-transformation medium)
747     :line-style (medium-line-style medium)
748     :text-style (medium-text-style medium)
749     ,@(compute-arg-list args))))
750 rouanet 1.11 (stream-add-output-record stream record)))
751 cvs 1.5 (when (stream-drawing-p stream)
752     (call-next-method))))
753 mikemac 1.1 (defmethod replay-output-record ((record ,class-name) stream
754 rouanet 1.18 &optional (region +everywhere+)
755     (x-offset 0) (y-offset 0))
756     (with-slots (x y initial-x1 initial-y1
757     ink clip transform line-style text-style ,@args) record
758     (let ((transformation (compose-translation-with-transformation
759     transform
760     (+ (- x initial-x1) x-offset)
761     (+ (- y initial-y1) y-offset))))
762     (let ((,old-medium (sheet-medium stream))
763     (,new-medium (make-merged-medium stream ink
764     (region-intersection clip
765     (untransform-region transformation region))
766     transformation line-style text-style)))
767     (unwind-protect
768     (progn
769 gilbert 1.33 (setf (%sheet-medium stream) ,new-medium) ;is sheet a sheet-with-medium-mixin? --GB
770     (setf (%medium-sheet ,new-medium) stream) ;is medium a basic-medium? --GB
771 rouanet 1.18 (,method-name ,new-medium ,@args))
772 gilbert 1.33 (setf (%sheet-medium stream) ,old-medium))))))))) ;is sheet a sheet-with-medium-mixin? --GB
773 mikemac 1.1
774 rouanet 1.11 (def-grecording draw-point (point-x point-y)
775 adejneka 1.14 (with-transformed-position (transform point-x point-y)
776     (values point-x point-y point-x point-y)))
777 mikemac 1.1
778     (def-grecording draw-points (coord-seq)
779 adejneka 1.14 (with-transformed-positions (transform coord-seq)
780     (loop for (x y) on coord-seq by #'cddr
781     minimize x into min-x
782     minimize y into min-y
783     maximize x into max-x
784     maximize y into max-y
785     finally (return (values min-x min-y max-x max-y)))))
786 mikemac 1.1
787 rouanet 1.11 (def-grecording draw-line (point-x1 point-y1 point-x2 point-y2)
788 adejneka 1.14 (with-transformed-position (transform point-x1 point-y1)
789     (with-transformed-position (transform point-x2 point-y2)
790     (values (min point-x1 point-x2) (min point-y1 point-y2)
791     (max point-x1 point-x2) (max point-y1 point-y2)))))
792 mikemac 1.1
793     (def-grecording draw-lines (coord-seq)
794 adejneka 1.14 (with-transformed-positions (transform coord-seq)
795     (loop for (x y) on coord-seq by #'cddr
796     minimize x into min-x
797     minimize y into min-y
798     maximize x into max-x
799     maximize y into max-y
800     finally (return (values min-x min-y max-x max-y)))))
801 mikemac 1.1
802     (def-grecording draw-polygon (coord-seq closed filled)
803 adejneka 1.16 ;; FIXME !!!
804     ;; If LINE-STYLE-JOINT-SHAPE is :MITTER, then the bb is larger than
805     ;; these numbers by (LINE-THICKNESS / (sin (angle / 2))),
806     ;; which is larger than LINE-THICKNESS
807 adejneka 1.14 (with-transformed-positions (transform coord-seq)
808     (loop for (x y) on coord-seq by #'cddr
809     minimize x into min-x
810     minimize y into min-y
811     maximize x into max-x
812     maximize y into max-y
813     finally (return (values min-x min-y max-x max-y)))))
814 mikemac 1.1
815     (def-grecording draw-rectangle (left top right bottom filled)
816 adejneka 1.17 ;; FIXME!!! If the rectangle is a line/point, MAKE-RECTANGLE* gives +NOWHERE+,
817     ;; and BOUNDING-RECTANGLE* signals an error.
818     (bounding-rectangle* (transform-region transform
819     (make-rectangle* left top right bottom))))
820 mikemac 1.1
821     (def-grecording draw-ellipse (center-x center-y
822     radius-1-dx radius-1-dy radius-2-dx radius-2-dy
823     start-angle end-angle filled)
824 adejneka 1.17 (bounding-rectangle* (transform-region transform
825     (make-ellipse* center-x center-y
826     radius-1-dx radius-1-dy radius-2-dx radius-2-dy
827     :start-angle start-angle
828     :end-angle end-angle))))
829 rouanet 1.11
830     (def-grecording draw-text (string point-x point-y start end
831     align-x align-y toward-x toward-y transform-glyphs)
832 adejneka 1.16 ;; FIXME!!! transformation
833 rouanet 1.11 (let* ((width (stream-string-width stream string
834     :start start :end end
835     :text-style text-style))
836 strandh 1.26 (ascent (text-style-ascent text-style (sheet-medium stream)))
837     (descent (text-style-descent text-style (sheet-medium stream)))
838 rouanet 1.11 (height (+ ascent descent))
839     left top right bottom)
840     (ecase align-x
841     (:left (setq left point-x
842     right (+ point-x width)))
843     (:right (setq left (- point-x width)
844     right point-x))
845     (:center (setq left (- point-x (round width 2))
846     right (+ point-x (round width 2)))))
847     (ecase align-y
848     (:baseline (setq top (- point-y height)
849     bottom (+ point-y descent)))
850     (:top (setq top point-y
851     bottom (+ point-y height)))
852     (:bottom (setq top (- point-y height)
853     bottom point-y))
854     (:center (setq top (- point-y (floor height 2))
855     bottom (+ point-y (ceiling height 2)))))
856     (values left top right bottom)))
857 mikemac 1.1
858    
859     ;;; Text recording class
860    
861     (defclass text-displayed-output-record (displayed-output-record)
862 moore 1.34 ())
863    
864     (defclass text-displayed-output-record-mixin
865     (text-displayed-output-record displayed-output-record-mixin)
866 mikemac 1.1 ((strings :initform nil)
867     (baseline :initform 0)
868 adejneka 1.22 (width :initform 0)
869 mikemac 1.1 (max-height :initform 0)
870 cvs 1.6 (start-x :initarg :start-x)
871     (start-y :initarg :start-y)
872 mikemac 1.1 (end-x)
873 cvs 1.8 (end-y)
874     (wrapped :initform nil
875 adejneka 1.21 :accessor text-record-wrapped)))
876 mikemac 1.1
877     (defun text-displayed-output-record-p (x)
878     (typep x 'text-displayed-output-record))
879    
880 moore 1.34 (defmethod print-object ((self text-displayed-output-record-mixin) stream)
881 cvs 1.8 (print-unreadable-object (self stream :type t :identity t)
882     (if (slot-boundp self 'start-x)
883     (with-slots (start-x start-y strings) self
884     (format stream "~D,~D ~S" start-x start-y (mapcar #'third strings)))
885     (format stream "empty"))))
886 mikemac 1.1
887 adejneka 1.21 (defgeneric add-character-output-to-text-record
888     (text-record character text-style width height baseline))
889     (defgeneric add-string-output-to-text-record
890     (text-record string start end text-style width height baseline))
891     (defgeneric text-displayed-output-record-string (text-record))
892    
893     ;;; Methods
894 moore 1.34 (defmethod tree-recompute-extent
895     ((text-record text-displayed-output-record-mixin))
896 adejneka 1.22 (with-slots (parent x y
897     x1 y1 x2 y2 width max-height) text-record
898     (setq x1 (coordinate x)
899     y1 (coordinate y)
900     x2 (coordinate (+ x width))
901     y2 (coordinate (+ y max-height)))))
902    
903 moore 1.34 (defmethod* (setf output-record-position) :before
904     (nx ny (record text-displayed-output-record-mixin))
905 adejneka 1.22 (with-slots (x1 y1 x2 y2 x y start-x start-y end-x end-y) record
906 rouanet 1.23 (let ((dx (- nx x))
907     (dy (- ny y)))
908     (incf start-x dx)
909     (incf start-y dy)
910     (incf end-x dx)
911     (incf end-y dy))))
912 cvs 1.9
913 moore 1.34 (defmethod add-character-output-to-text-record ((text-record text-displayed-output-record-mixin)
914 adejneka 1.22 character text-style char-width height
915 mikemac 1.1 new-baseline)
916 adejneka 1.22 (with-slots (strings baseline width max-height start-y end-x end-y) text-record
917 cvs 1.7 (if (and strings (eq (second (first (last strings))) text-style))
918     (vector-push-extend character (third (first (last strings))))
919     (setq strings (nconc strings (list (list end-x text-style (make-array 1 :initial-element character :element-type 'character :adjustable t :fill-pointer t))))))
920     (setq baseline (max baseline new-baseline)
921 adejneka 1.22 end-x (+ end-x char-width)
922 mikemac 1.1 max-height (max max-height height)
923 cvs 1.9 end-y (max end-y (+ start-y max-height))
924 adejneka 1.22 width (+ width char-width)))
925 cvs 1.9 (tree-recompute-extent text-record))
926 mikemac 1.1
927 moore 1.34 (defmethod add-string-output-to-text-record ((text-record text-displayed-output-record-mixin)
928 adejneka 1.22 string start end text-style string-width height
929 mikemac 1.1 new-baseline)
930 adejneka 1.20 (if end
931 adejneka 1.21 (setq end (min end (1- (length string))))
932 adejneka 1.20 (setq end (1- (length string))))
933     (let ((length (max 0 (- (1+ end) start))))
934 mikemac 1.28 (cond
935     ((= length 1)
936     (add-character-output-to-text-record text-record (aref string start) text-style string-width height new-baseline))
937     (t
938     (setq string (make-array length :displaced-to string
939     :displaced-index-offset start
940     :element-type (array-element-type string)))
941     (with-slots (strings baseline width max-height start-y end-x end-y) text-record
942     (setq baseline (max baseline new-baseline)
943     strings (nconc strings
944     (list (list end-x text-style
945     (make-array (length string)
946     :initial-contents string
947     :element-type 'character
948     :adjustable t
949     :fill-pointer t))))
950     end-x (+ end-x string-width)
951     max-height (max max-height height)
952     end-y (max end-y (+ start-y max-height))
953     width (+ width string-width)))
954     (tree-recompute-extent text-record)))))
955 mikemac 1.1
956 moore 1.34 (defmethod replay-output-record ((record text-displayed-output-record-mixin)
957     stream
958 adejneka 1.21 &optional region (x-offset 0) (y-offset 0))
959 mikemac 1.30 (declare (ignore region))
960 adejneka 1.20 (with-slots (strings baseline max-height start-x start-y wrapped
961 adejneka 1.21 x y x1 y1 initial-x1 initial-y1) record
962 cvs 1.7 (let ((old-medium (sheet-medium stream))
963     (new-medium (make-medium (port stream) stream)))
964     (unwind-protect
965 adejneka 1.22 (progn
966 gilbert 1.33 (setf (%sheet-medium stream) new-medium) ;is sheet a sheet-with-medium-mixin? --GB
967     (setf (%medium-sheet new-medium) stream) ;is medium a basic medium?
968 adejneka 1.22 (setf (medium-transformation new-medium)
969 adejneka 1.20 (make-translation-transformation
970 adejneka 1.22 x-offset
971     y-offset))
972    
973 rouanet 1.23 (setf (stream-cursor-position stream) (values start-x start-y))
974 adejneka 1.22 (letf (((slot-value stream 'baseline) baseline))
975     (loop for (x text-style string) in strings
976     do (setf (medium-text-style new-medium) text-style)
977 mikemac 1.28 (setf (stream-cursor-position stream)
978     (values (+ x (- x1 initial-x1)) start-y))
979     (stream-write-line stream string)))
980 adejneka 1.22 ;; clipping region
981     #|restore cursor position? set to (end-x,end-y)?|#
982     #+nil(loop for y = (+ start-y baseline)
983     for (x text-style string) in strings
984     do (setf (medium-text-style new-medium) text-style)
985     (draw-text* (sheet-medium stream) string x y
986     :text-style text-style :clipping-region (untransform-region (medium-transformation new-medium) region)))
987     (if wrapped
988     (draw-rectangle* (sheet-medium stream)
989     (+ wrapped 0) start-y (+ wrapped 4) (+ start-y max-height)
990     :ink +foreground-ink+
991     :filled t)))
992 gilbert 1.33 (setf (%sheet-medium stream) old-medium))))) ;is sheet a sheet-with-medium-mixin? --GB
993 mikemac 1.1
994 moore 1.34 (defmethod output-record-start-cursor-position
995     ((record text-displayed-output-record-mixin))
996 mikemac 1.1 (with-slots (start-x start-y) record
997     (values start-x start-y)))
998    
999 moore 1.34 (defmethod output-record-end-cursor-position
1000     ((record text-displayed-output-record-mixin))
1001 mikemac 1.1 (with-slots (end-x end-y) record
1002     (values end-x end-y)))
1003    
1004 moore 1.34 (defmethod text-displayed-output-record-string
1005     ((record text-displayed-output-record-mixin))
1006 mikemac 1.1 (with-slots (strings) record
1007     (loop for result = ""
1008     for s in strings
1009     do (setq result (concatenate 'string result (third s)))
1010     finally (return result))))
1011 cvs 1.5
1012    
1013 moore 1.34 (defclass stream-text-record (text-displayed-output-record-mixin)
1014     ())
1015    
1016 adejneka 1.21 ;;; Methods for text output to output recording streams
1017 adejneka 1.22 (defmethod stream-text-output-record ((stream standard-output-recording-stream) text-style)
1018 mikemac 1.30 (declare (ignore text-style))
1019 adejneka 1.20 (let ((record (stream-current-text-output-record stream)))
1020     (unless record
1021     (setf (stream-current-text-output-record stream)
1022 moore 1.34 (setq record (make-instance 'stream-text-record)))
1023 adejneka 1.22 (with-slots (start-x start-y end-x end-y x1 y1 x2 y2 x y
1024 adejneka 1.20 initial-x1 initial-y1) record
1025 cvs 1.8 (multiple-value-bind (cx cy) (stream-cursor-position stream)
1026 adejneka 1.22 (setq start-x cx
1027     start-y cy
1028 cvs 1.8 end-x start-x
1029 cvs 1.9 end-y start-y
1030 adejneka 1.22 x1 (coordinate start-x)
1031     x2 (coordinate end-x)
1032     y1 (coordinate start-y)
1033     y2 (coordinate end-y)
1034 adejneka 1.20 initial-x1 x1
1035 adejneka 1.22 initial-y1 y1
1036     x start-x
1037     y start-y))))
1038 adejneka 1.20 record))
1039    
1040 adejneka 1.22 (defmethod stream-close-text-output-record ((stream standard-output-recording-stream))
1041 adejneka 1.20 (let ((record (stream-current-text-output-record stream)))
1042     (when record
1043     (setf (stream-current-text-output-record stream) nil)
1044     #|record stream-current-cursor-position to (end-x record) - already done|#
1045     (stream-add-output-record stream record))))
1046    
1047 adejneka 1.22 (defmethod stream-add-character-output ((stream standard-output-recording-stream)
1048 adejneka 1.20 character text-style
1049     width height baseline)
1050     (add-character-output-to-text-record (stream-text-output-record stream text-style)
1051     character text-style width height baseline))
1052    
1053 adejneka 1.22 (defmethod stream-add-string-output ((stream standard-output-recording-stream)
1054 adejneka 1.20 string start end text-style
1055     width height baseline)
1056     (add-string-output-to-text-record (stream-text-output-record stream text-style)
1057     string start end text-style
1058     width height baseline))
1059    
1060     (defmacro without-local-recording (stream &body body)
1061 adejneka 1.22 `(letf (((slot-value ,stream 'local-record-p) nil))
1062     ,@body))
1063    
1064     (defmethod stream-write-line :around ((stream standard-output-recording-stream) line)
1065     (when (and (stream-recording-p stream)
1066     (slot-value stream 'local-record-p))
1067     (let* ((medium (sheet-medium stream))
1068 strandh 1.26 (text-style (medium-text-style medium)))
1069 adejneka 1.22 (stream-add-string-output stream line 0 nil text-style
1070     (stream-string-width stream line
1071     :text-style text-style)
1072 strandh 1.26 (text-style-height text-style medium)
1073     (text-style-ascent text-style medium))))
1074 adejneka 1.22 (when (stream-drawing-p stream)
1075     (without-local-recording stream
1076     (call-next-method))))
1077 cvs 1.5
1078 adejneka 1.22 #+nil
1079     (defmethod stream-write-char :around ((stream standard-output-recording-stream) char)
1080 adejneka 1.20 (when (and (stream-recording-p stream)
1081     (slot-value stream 'local-record-p))
1082     (if (or (eql char #\return)
1083     (eql char #\newline))
1084     (stream-close-text-output-record stream)
1085 cvs 1.8 (let* ((medium (sheet-medium stream))
1086 strandh 1.26 (text-style (medium-text-style medium)))
1087 adejneka 1.20 (stream-add-character-output stream char text-style
1088     (stream-character-width stream char :text-style text-style)
1089 strandh 1.26 (text-style-height text-style medium)
1090     (text-style-ascent text-style medium)))))
1091 adejneka 1.20 (without-local-recording stream
1092     (call-next-method)))
1093    
1094 adejneka 1.21 #+nil
1095 adejneka 1.22 (defmethod stream-write-string :around ((stream standard-output-recording-stream) string
1096 adejneka 1.20 &optional (start 0) end)
1097 adejneka 1.21 ;; Problem: it is necessary to check for line wrapping. Now the
1098     ;; default method for STREAM-WRITE-STRING do char-by-char output,
1099     ;; therefore STREAM-WRITE-CHAR can do the right thing.
1100 adejneka 1.20 (when (and (stream-recording-p stream)
1101     (slot-value stream 'local-record-p))
1102     (let* ((medium (sheet-medium stream))
1103 strandh 1.26 (text-style (medium-text-style medium)))
1104 adejneka 1.20 (stream-add-string-output stream string start end text-style
1105     (stream-string-width stream string
1106     :start start :end end
1107     :text-style text-style)
1108 strandh 1.26 (text-style-height text-style medium)
1109     (text-style-ascent text-style medium))))
1110 adejneka 1.20 (without-local-recording stream
1111     (call-next-method)))
1112    
1113    
1114 adejneka 1.22 (defmethod stream-finish-output :after ((stream standard-output-recording-stream))
1115 adejneka 1.20 (stream-close-text-output-record stream))
1116    
1117 adejneka 1.22 (defmethod stream-force-output :after ((stream standard-output-recording-stream))
1118 adejneka 1.20 (stream-close-text-output-record stream))
1119    
1120 adejneka 1.22 (defmethod stream-terpri :after ((stream standard-output-recording-stream))
1121 adejneka 1.21 (stream-close-text-output-record stream))
1122    
1123 rouanet 1.23 (defmethod* (setf stream-cursor-position) :after (x y (stream standard-output-recording-stream))
1124 mikemac 1.30 (declare (ignore x y))
1125 adejneka 1.20 (stream-close-text-output-record stream))
1126    
1127 adejneka 1.22 ;(defmethod stream-set-cursor-position :after ((stream standard-output-recording-stream))
1128 adejneka 1.20 ; (stream-close-text-output-record stream))
1129 cvs 1.5
1130 adejneka 1.22 (defmethod stream-wrap-line :before ((stream standard-output-recording-stream))
1131 cvs 1.5 (when (stream-recording-p stream)
1132 adejneka 1.20 (setf (text-record-wrapped (stream-text-output-record stream nil)) ; FIXME!
1133     (stream-text-margin stream))))

  ViewVC Help
Powered by ViewVC 1.1.5