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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.48 - (show annotations)
Sun Jun 16 03:28:30 2002 UTC (11 years, 10 months ago) by adejneka
Branch: MAIN
Changes since 1.47: +29 -39 lines
Used new LETF.
1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 1998,1999,2000,2001 by Michael McDonald (mikemac@mikemac.com)
4 ;;; (c) copyright 2000 by
5 ;;; Robert Strandh (strandh@labri.u-bordeaux.fr)
6 ;;; (c) copyright 2001 by
7 ;;; Arnaud Rouanet (rouanet@emi.u-bordeaux.fr)
8 ;;; Lionel Salabartan (salabart@emi.u-bordeaux.fr)
9 ;;; (c) copyright 2001, 2002 by Alexey Dejneka (adejneka@comail.ru)
10
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 ;;; TODO:
27 ;;;
28 ;;; - Scrolling does not work correctly. Region is given in "window"
29 ;;; coordinates, without bounding-rectangle-position transformation.
30 ;;;
31 ;;; - Redo setf*-output-record-position, extent recomputation for
32 ;;; compound records
33 ;;;
34 ;;; - When DRAWING-P is NIL, should stream cursor move?
35 ;;;
36 ;;; - :{X,Y}-OFFSET.
37
38 ;;; Bug: (SETF OUTPUT-RECORD-POSITION) returns the record instead of
39 ;;; the position. It is useful for debugging, but it is wrong.
40
41 ;;; Troubles
42
43 ;;; DC
44 ;;;
45 ;;; Some GFs are defined to have "a default method on CLIM's standard
46 ;;; output record class". What does it mean? What is "CLIM's standard
47 ;;; output record class"? Is it OUTPUT-RECORD or BASIC-OUTPUT-RECORD?
48 ;;; Now they are defined on OUTPUT-RECORD.
49
50 ;;; TDO
51 ;;;
52 ;;; Text output record must save ink and clipping region. But its
53 ;;; protocol does not give any way to do it! And a user can put in a
54 ;;; history a record of any class :(. Now we are using
55 ;;; *DRAWING-OPTIONS* to put the necessary information and make sure
56 ;;; that only instances of STANDARD-TEXT-OUTPUT-RECORD are used for
57 ;;; recording. -- APD, 2002-06-15.
58
59 (in-package :CLIM-INTERNALS)
60
61 (define-protocol-class output-record (bounding-rectangle)
62 ())
63
64 (define-protocol-class displayed-output-record (output-record)
65 ())
66
67 ;;; 16.2.1. The Basic Output Record Protocol
68 #+:cmu(declaim (ftype (function (output-record) (values rational rational))
69 output-record-position))
70 (defgeneric output-record-position (record)
71 (:documentation
72 "Returns the x and y position of RECORD. The position is the
73 position of the upper-left corner of its bounding rectangle. The
74 position is relative to the stream, where (0,0) is (initially) the
75 upper-left corner of the stream."))
76
77 (defgeneric* (setf output-record-position) (x y record))
78
79 #+:cmu(declaim (ftype (function (output-record) (values integer integer))
80 output-record-start-cursor-position))
81 (defgeneric output-record-start-cursor-position (record)
82 (:documentation
83 "Returns the x and y starting cursor position of RECORD. The
84 positions are relative to the stream, where (0,0) is (initially) the
85 upper-left corner of the stream."))
86
87 (defgeneric* (setf output-record-start-cursor-position) (x y record))
88
89 #+:cmu(declaim (ftype (function (output-record) (values integer integer))
90 output-record-end-cursor-position))
91 (defgeneric output-record-end-cursor-position (record)
92 (:documentation
93 "Returns the x and y ending cursor position of RECORD. The
94 positions are relative to the stream, where (0,0) is (initially) the
95 upper-left corner of the stream."))
96
97 (defgeneric* (setf output-record-end-cursor-position) (x y record))
98
99 (defgeneric output-record-parent (record)
100 (:documentation
101 "Returns the output record that is the parent of RECORD, or NIL if
102 RECORD has no parent."))
103
104 (defgeneric (setf output-record-parent) (parent record)
105 (:documentation "Non-standard function."))
106
107 (defgeneric replay-output-record (record stream
108 &optional region x-offset y-offset)
109 (:documentation "Displays the output captured by RECORD on the
110 STREAM, exactly as it was originally captured. The current user
111 transformation, line style, text style, ink and clipping region of
112 STREAM are all ignored. Instead, these are gotten from the output
113 record.
114
115 Only those records that overlap REGION are displayed."))
116
117 (defgeneric output-record-hit-detection-rectangle* (record))
118
119 (defgeneric output-record-refined-position-test (record x y))
120
121 (defgeneric highlight-output-record (record stream state))
122
123 (defgeneric displayed-output-record-ink (displayed-output-record))
124
125 ;;; 16.2.2. Output Record "Database" Protocol
126
127 (defgeneric output-record-children (record))
128
129 (defgeneric add-output-record (child record))
130
131 (defgeneric delete-output-record (child record &optional errorp))
132
133 (defgeneric clear-output-record (record))
134
135 (defgeneric output-record-count (record))
136
137 (defgeneric map-over-output-records-containing-position
138 (function record x y &optional x-offset y-offset &rest function-args)
139 (:documentation "Maps over all of the children of RECORD that
140 contain the point at (X,Y), calling FUNCTION on each one. FUNCTION is
141 a function of one or more arguments, the first argument being the
142 record containing the point. FUNCTION is also called with all of
143 FUNCTION-ARGS as APPLY arguments.
144
145 If there are multiple records that contain the point,
146 MAP-OVER-OUTPUT-RECORDS-CONTAINING-POSITION hits the most recently
147 inserted record first and the least recently inserted record
148 last. Otherwise, the order in which the records are traversed is
149 unspecified."))
150
151 (defgeneric map-over-output-records-overlapping-region
152 (function record region &optional x-offset y-offset &rest function-args)
153 (:documentation "Maps over all of the children of the RECORD that
154 overlap the REGION, calling FUNCTION on each one. FUNCTION is a
155 function of one or more arguments, the first argument being the record
156 overlapping the region. FUNCTION is also called with all of
157 FUNCTION-ARGS as APPLY arguments.
158
159 If there are multiple records that overlap the region and that overlap
160 each other, MAP-OVER-OUTPUT-RECORDS-OVERLAPPING-REGION hits the least
161 recently inserted record first and the most recently inserted record
162 last. Otherwise, the order in which the records are traversed is
163 unspecified. "))
164
165 ;;; From the Franz CLIM user's guide but not in the spec... clearly necessary.
166 ;;; What is its status? -- APD, 2002-06-14.
167 (defgeneric map-over-output-records
168 (continuation record &optional x-offset y-offset &rest continuation-args))
169
170 ;;; 16.2.3. Output Record Change Notification Protocol
171
172 (defgeneric recompute-extent-for-new-child (record child))
173
174 (defgeneric recompute-extent-for-changed-child
175 (record child old-min-x old-min-y old-max-x old-max-y))
176
177 (defgeneric tree-recompute-extent (record))
178
179 ;;; 16.3. Types of Output Records
180 (define-protocol-class graphics-displayed-output-record (output-record)
181 ())
182
183 (define-protocol-class text-displayed-output-record (displayed-output-record)
184 ())
185
186 ;;; 16.3.3. Text Displayed Output Record
187 (defgeneric add-character-output-to-text-record
188 (text-record character text-style width height baseline))
189
190 (defgeneric add-string-output-to-text-record
191 (text-record string start end text-style width height baseline))
192
193 (defgeneric text-displayed-output-record-string (text-record))
194
195 ;;; 16.4. Output Recording Streams
196 (define-protocol-class output-recording-stream ()
197 ())
198
199 ;;; 16.4.1. The Output Recording Stream Protocol
200 (defgeneric stream-recording-p (stream))
201
202 (defgeneric (setf stream-recording-p) (recording-p stream))
203
204 (defgeneric stream-drawing-p (stream))
205
206 (defgeneric (setf stream-drawing-p) (drawing-p stream))
207
208 (defgeneric stream-output-history (stream))
209
210 (defgeneric stream-current-output-record (stream))
211
212 (defgeneric (setf stream-current-output-record) (record stream))
213
214 (defgeneric stream-add-output-record (stream record))
215
216 (defgeneric stream-replay (stream &optional region))
217
218 (defgeneric erase-output-record (record stream &optional errorp))
219
220 ;;; 16.4.3. Text Output Recording
221 (defgeneric stream-text-output-record (stream text-style))
222
223 (defgeneric stream-close-text-output-record (stream))
224
225 (defgeneric stream-add-character-output
226 (stream character text-style width height baseline))
227
228 (defgeneric stream-add-string-output
229 (stream string start end text-style width height baseline))
230
231 ;;; 16.4.4. Output Recording Utilities
232 (defgeneric invoke-with-output-recording-options
233 (stream continuation record draw))
234
235 (defgeneric invoke-with-new-output-record (stream continuation record-type
236 &rest initargs
237 &allow-other-keys))
238
239 (defgeneric invoke-with-output-to-output-record
240 (stream continuation record-type
241 &rest initargs
242 &allow-other-keys))
243
244 (defgeneric make-design-from-output-record (record))
245
246
247 ;;;; Implementation
248
249 (defclass basic-output-record (standard-bounding-rectangle output-record)
250 ((parent :initarg :parent ; XXX
251 :initform nil
252 :accessor output-record-parent)) ; XXX
253 (:documentation "Implementation class for the Basic Output Record Protocol."))
254
255 (defmethod initialize-instance :after ((record basic-output-record)
256 &key (x-position 0) (y-position 0)
257 &rest args)
258 (declare (ignore args))
259 (with-slots (x1 y1 x2 y2) record
260 (setq x1 x-position
261 y1 y-position
262 x2 x-position
263 y2 y-position)))
264
265 (defclass compound-output-record (basic-output-record)
266 ((x :initarg :x-position
267 :initform 0
268 :documentation "X-position of the empty record.")
269 (y :initarg :y-position
270 :initform 0
271 :documentation "Y-position of the empty record.")
272 (in-moving-p :initform nil
273 :documentation "Is set while changing the position."))
274 (:documentation "Implementation class for output records with children."))
275
276 ;;; 16.2.1. The Basic Output Record Protocol
277 (defmethod output-record-position ((record basic-output-record))
278 (bounding-rectangle-position record))
279
280 (defmethod* (setf output-record-position) (nx ny (record basic-output-record))
281 (with-slots (x1 y1 x2 y2) record
282 (let ((dx (- nx x1))
283 (dy (- ny y1)))
284 (setf x1 nx y1 ny
285 x2 (+ x2 dx) y2 (+ y2 dy))))
286 record)
287
288 (defmethod* (setf output-record-position) :around
289 (nx ny (record basic-output-record))
290 (declare (ignore nx ny))
291 (with-bounding-rectangle* (min-x min-y max-x max-y) record
292 (call-next-method)
293 (let ((parent (output-record-parent record)))
294 (when parent
295 (recompute-extent-for-changed-child parent record
296 min-x min-y max-x max-y))))
297 record)
298
299 (defmethod* (setf output-record-position) :before
300 (nx ny (record compound-output-record))
301 (with-slots (x1 y1 in-moving-p) record
302 (letf ((in-moving-p t))
303 (let ((dx (- nx x1))
304 (dy (- ny y1)))
305 (map-over-output-records
306 (lambda (child)
307 (multiple-value-bind (x y) (output-record-position child)
308 (setf (output-record-position child)
309 (values (+ x dx) (+ y dy)))))
310 record)))))
311
312 (defmethod output-record-start-cursor-position ((record basic-output-record))
313 (values nil nil))
314
315 (defmethod* (setf output-record-start-cursor-position)
316 (x y (record basic-output-record))
317 (declare (ignore x y))
318 nil)
319
320 (defmethod output-record-end-cursor-position ((record basic-output-record))
321 (values nil nil))
322
323 (defmethod* (setf output-record-end-cursor-position)
324 (x y (record basic-output-record))
325 (declare (ignore x y))
326 nil)
327
328 (defun replay (record stream &optional region)
329 (stream-close-text-output-record stream)
330 (when (stream-drawing-p stream)
331 (with-cursor-off stream
332 (letf (((stream-cursor-position stream) (values 0 0))
333 ((stream-recording-p stream) nil))
334 (replay-output-record record stream region)))))
335
336 (defmethod replay-output-record ((record compound-output-record) stream
337 &optional region (x-offset 0) (y-offset 0))
338 (when (null region)
339 (setq region +everywhere+))
340 (map-over-output-records-overlapping-region
341 #'replay-output-record record region x-offset y-offset
342 stream region x-offset y-offset))
343
344 (defmethod output-record-hit-detection-rectangle* ((record output-record))
345 ;; XXX DC
346 (bounding-rectangle* record))
347
348 (defmethod output-record-refined-position-test ((record basic-output-record)
349 x y)
350 (declare (ignore x y))
351 t)
352
353 ;;; XXX Should this only be defined on recording streams?
354 (defmethod highlight-output-record ((record output-record)
355 stream state)
356 ;; XXX DC
357 ;; XXX Disable recording?
358 (letf (((medium-transformation stream) +identity-transformation+))
359 (multiple-value-bind (x1 y1 x2 y2)
360 (output-record-hit-detection-rectangle* record)
361 (ecase state
362 (:highlight
363 (draw-rectangle* (sheet-medium stream) x1 y1 x2 y2
364 :filled nil :ink +foreground-ink+))
365 (:unhighlight
366 (draw-rectangle* (sheet-medium stream) x1 y1 x2 y2
367 :filled nil :ink +background-ink+))))))
368
369 ;;; 16.2.2. The Output Record "Database" Protocol
370 (defmethod output-record-children ((record basic-output-record))
371 nil)
372
373 (defmethod add-output-record (child (record basic-output-record))
374 (declare (ignore child))
375 (error "Cannot add a child to ~S." record))
376
377 (defmethod add-output-record :before (child (record compound-output-record))
378 (let ((parent (output-record-parent child)))
379 (when parent
380 (restart-case
381 (error "~S already has a parent ~S." child parent)
382 (delete ()
383 :report "Delete from the old parent."
384 (delete-output-record child parent))))))
385
386 (defmethod add-output-record :after (child (record compound-output-record))
387 (recompute-extent-for-new-child record child))
388
389 (defmethod delete-output-record (child (record basic-output-record)
390 &optional (errorp t))
391 (declare (ignore child))
392 (when errorp (error "Cannot delete a child from ~S." record)))
393
394 (defmethod delete-output-record :after (child (record compound-output-record)
395 &optional (errorp t))
396 (declare (ignore errorp))
397 (with-bounding-rectangle* (x1 y1 x2 y2) child
398 (recompute-extent-for-changed-child record child x1 y1 x2 y2)))
399
400 (defmethod clear-output-record ((record basic-output-record))
401 (error "Cannot clear ~S." record))
402
403 (defmethod clear-output-record :after ((record compound-output-record))
404 (with-slots (x y x1 y1 x2 y2) record
405 (setf x1 x y1 y
406 x2 x y2 y)))
407
408 (defmethod output-record-count ((record basic-output-record))
409 0)
410
411 (defmethod map-over-output-records
412 (function (record basic-output-record)
413 &optional (x-offset 0) (y-offset 0)
414 &rest function-args)
415 (declare (ignore function x-offset y-offset function-args))
416 nil)
417
418 ;;; This needs to work in "most recently added last" order. Is this
419 ;;; implementation right? -- APD, 2002-06-13
420 #+nil
421 (defmethod map-over-output-records
422 (function (record compound-output-record)
423 &optional (x-offset 0) (y-offset 0)
424 &rest function-args)
425 (declare (ignore x-offset y-offset))
426 (map nil (lambda (child) (apply function child function-args))
427 (output-record-children record)))
428
429 (defmethod map-over-output-records-containing-position
430 (function (record basic-output-record) x y
431 &optional (x-offset 0) (y-offset 0)
432 &rest function-args)
433 (declare (ignore function x y x-offset y-offset function-args))
434 nil)
435
436 ;;; This needs to work in "most recently added first" order. Is this
437 ;;; implementation right? -- APD, 2002-06-13
438 #+nil
439 (defmethod map-over-output-records-containing-position
440 (function (record compound-output-record) x y
441 &optional (x-offset 0) (y-offset 0)
442 &rest function-args)
443 (declare (ignore x-offset y-offset))
444 (map nil
445 (lambda (child)
446 (when (and (multiple-value-bind (min-x min-y max-x max-y)
447 (output-record-hit-detection-rectangle* child)
448 (and (<= min-x x max-x) (<= min-y y max-y)))
449 (output-record-refined-position-test child x y))
450 (apply function child function-args)))
451 (output-record-children record)))
452
453 (defmethod map-over-output-records-overlapping-region
454 (function (record basic-output-record) region
455 &optional (x-offset 0) (y-offset 0)
456 &rest function-args)
457 (declare (ignore function region x-offset y-offset function-args))
458 nil)
459
460 ;;; This needs to work in "most recently added last" order. Is this
461 ;;; implementation right? -- APD, 2002-06-13
462 #+nil
463 (defmethod map-over-output-records-overlapping-region
464 (function (record compound-output-record) region
465 &optional (x-offset 0) (y-offset 0)
466 &rest function-args)
467 (declare (ignore x-offset y-offset))
468 (map nil
469 (lambda (child) (when (region-intersects-region-p region child)
470 (apply function child function-args)))
471 (output-record-children record)))
472
473 ;;; 16.2.3. Output Record Change Notification Protocol
474 (defmethod recompute-extent-for-new-child
475 ((record compound-output-record) child)
476 (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2) record
477 (with-slots (parent x1 y1 x2 y2) record
478 (if (= 1 (length (output-record-children record)))
479 (setf (values x1 y1 x2 y2) (bounding-rectangle* child))
480 (with-bounding-rectangle* (x1-child y1-child x2-child y2-child) child
481 (minf x1 x1-child)
482 (minf y1 y1-child)
483 (maxf x2 x2-child)
484 (maxf y2 y2-child)))
485 (when parent
486 (recompute-extent-for-changed-child parent record
487 old-x1 old-y1 old-x2 old-y2))))
488 record)
489
490 (defmethod %tree-recompute-extent* ((record compound-output-record))
491 ;; Internal helper function
492 (let ((new-x1 0)
493 (new-y1 0)
494 (new-x2 0)
495 (new-y2 0)
496 (first-time t))
497 (map-over-output-records
498 (lambda (child)
499 (if first-time
500 (progn
501 (multiple-value-setq (new-x1 new-y1 new-x2 new-y2)
502 (bounding-rectangle* child))
503 (setq first-time nil))
504 (with-bounding-rectangle* (cx1 cy1 cx2 cy2) child
505 (minf new-x1 cx1)
506 (minf new-y1 cy1)
507 (maxf new-x2 cx2)
508 (maxf new-y2 cy2))))
509 record)
510 (if first-time
511 (with-slots (x y) record
512 (values x y x y))
513 (values new-x1 new-y1 new-x2 new-y2))))
514
515 (defmethod recompute-extent-for-changed-child
516 ((record compound-output-record) changed-child
517 old-min-x old-min-y old-max-x old-max-y)
518 ;; If the child's old and new bbox lies entirely within the record's bbox
519 ;; then no change need be made to the record's bbox. Otherwise, if some part
520 ;; of the child's bbox was on the record's bbox and is now inside, examine
521 ;; all the children to determine the correct new bbox.
522 (with-slots (x1 y1 x2 y2) record
523 (with-bounding-rectangle* (child-x1 child-y1 child-x2 child-y2)
524 changed-child
525 (unless (and (> x1 old-min-x) (> x1 child-x1)
526 (> y1 old-min-y) (> y1 child-y1)
527 (< x2 old-max-x) (< x2 child-x2)
528 (< y2 old-max-y) (< y2 child-y2))
529 ;; Don't know if changed-child has been deleted or what, so go through
530 ;; all the children and construct the updated bbox.
531 (setf (values x1 y1 x2 y2) (%tree-recompute-extent* record)))))
532 record)
533
534 (defmethod recompute-extent-for-changed-child :around
535 ((record compound-output-record) child
536 old-min-x old-min-y old-max-x old-max-y)
537 (declare (ignore child old-min-x old-min-y old-max-x old-max-y))
538 (unless (slot-value record 'in-moving-p)
539 (let ((old-rectangle (multiple-value-call #'make-bounding-rectangle
540 (bounding-rectangle* record))))
541 (call-next-method)
542 (with-slots (parent x1 y1 x2 y2) record
543 (when (and parent (not (region-equal old-rectangle record)))
544 (multiple-value-call #'recompute-extent-for-changed-child
545 (values parent record)
546 (bounding-rectangle* old-rectangle))))))
547 record)
548
549 (defmethod tree-recompute-extent ((record compound-output-record))
550 (with-slots (x1 y1 x2 y2) record
551 (setf (values x1 y1 x2 y2) (%tree-recompute-extent* record)))
552 record)
553
554 (defmethod tree-recompute-extent :around ((record compound-output-record))
555 (let ((old-rectangle (multiple-value-call #'make-bounding-rectangle
556 (bounding-rectangle* record))))
557 (call-next-method)
558 (with-slots (parent x1 y1 x2 y2) record
559 (when (and parent (not (region-equal old-rectangle record)))
560 (recompute-extent-for-changed-child parent record x1 y1 x2 y2))))
561 record)
562
563 ;;; 16.3.1. Standard output record classes
564
565 (defclass standard-sequence-output-record (compound-output-record)
566 ((children :initform (make-array 8 :adjustable t :fill-pointer 0)
567 :reader output-record-children)))
568
569 (defmethod add-output-record (child (record standard-sequence-output-record))
570 (vector-push-extend child (output-record-children record))
571 (setf (output-record-parent child) record))
572
573 (defmethod delete-output-record (child (record standard-sequence-output-record)
574 &optional (errorp t))
575 (with-slots (children) record
576 (let ((pos (position child children :test #'eq)))
577 (if (null pos)
578 (when errorp
579 (error "~S is not a child of ~S" child record))
580 (progn
581 (setq children (replace children children
582 :start1 pos
583 :start2 (1+ pos)))
584 (decf (fill-pointer children))
585 (setf (output-record-parent child) nil))))))
586
587 (defmethod clear-output-record ((record standard-sequence-output-record))
588 (let ((children (output-record-children record)))
589 (map 'nil (lambda (child) (setf (output-record-parent child) nil))
590 children)
591 (fill children nil)
592 (setf (fill-pointer children) 0)))
593
594 (defmethod output-record-count ((record standard-sequence-output-record))
595 (length (output-record-children record)))
596
597 (defmethod map-over-output-records
598 (function (record standard-sequence-output-record)
599 &optional (x-offset 0) (y-offset 0)
600 &rest function-args)
601 "Applies FUNCTION to all children in the order they were added."
602 (declare (ignore x-offset y-offset))
603 (loop with children = (output-record-children record)
604 for child across children
605 do (apply function child function-args)))
606
607 (defmethod map-over-output-records-containing-position
608 (function (record standard-sequence-output-record) x y
609 &optional (x-offset 0) (y-offset 0)
610 &rest function-args)
611 "Applies FUNCTION to children, containing (X,Y), in the reversed
612 order they were added."
613 (declare (ignore x-offset y-offset))
614 (loop with children = (output-record-children record)
615 for i from (1- (length children)) downto 0
616 for child = (aref children i)
617 when (and (multiple-value-bind (min-x min-y max-x max-y)
618 (output-record-hit-detection-rectangle* child)
619 (and (<= min-x x max-x) (<= min-y y max-y)))
620 (output-record-refined-position-test child x y))
621 do (apply function child function-args)))
622
623 (defmethod map-over-output-records-overlapping-region
624 (function (record standard-sequence-output-record) region
625 &optional (x-offset 0) (y-offset 0)
626 &rest function-args)
627 "Applies FUNCTION to children, overlapping REGION, in the order they
628 were added."
629 (declare (ignore x-offset y-offset))
630 (loop with children = (output-record-children record)
631 for child across children
632 when (region-intersects-region-p region child)
633 do (apply function child function-args)))
634
635 ;;; XXX bogus for now.
636 (defclass standard-tree-output-record (standard-sequence-output-record)
637 (
638 ))
639
640 ;;; 16.3.2. Graphics Displayed Output Records
641 (defclass standard-displayed-output-record (basic-output-record
642 displayed-output-record)
643 ((ink :initarg :ink :reader displayed-output-record-ink)
644 (initial-x1 :initarg :initial-x1)
645 (initial-y1 :initarg :initial-y1))
646 (:documentation "Implementation class for DISPLAYED-OUTPUT-RECORD."))
647
648 (defclass standard-graphics-displayed-output-record
649 (standard-displayed-output-record graphics-displayed-output-record)
650 ((clip :initarg :clipping-region
651 :documentation "Clipping region in user coordinates.")
652 (transform :initarg :transformation)
653 (line-style :initarg :line-style)
654 (text-style :initarg :text-style)))
655
656 (defmacro def-grecording (name (&rest args) &body body)
657 (let ((method-name (intern (format nil "MEDIUM-~A*" name)))
658 (class-name (intern (format nil "~A-OUTPUT-RECORD" name)))
659 (medium (gensym "MEDIUM"))
660 (border 'border)
661 (class-vars `((stream :initarg :stream)
662 ,@(loop for arg in args
663 collect `(,arg
664 :initarg ,(intern (symbol-name arg)
665 :keyword)))))
666 (arg-list (loop for arg in args
667 nconc `(,(intern (symbol-name arg) :keyword) ,arg))))
668 `(progn
669 (defclass ,class-name (standard-graphics-displayed-output-record)
670 ,class-vars)
671 (defmethod initialize-instance :after ((graphic ,class-name) &rest args)
672 (declare (ignore args))
673 (with-slots (x1 y1 x2 y2 initial-x1 initial-y1
674 stream ink clipping-region transform
675 line-style text-style
676 ,@args) graphic
677 (let ((,border (/ (line-style-effective-thickness
678 line-style (sheet-medium stream))
679 2)))
680 (declare (ignorable ,border))
681 (multiple-value-setq (x1 y1 x2 y2) (progn ,@body)))
682 (setf initial-x1 x1
683 initial-y1 y1)))
684 (defmethod ,method-name :around ((stream output-recording-stream) ,@args)
685 ;; XXX STANDARD-OUTPUT-RECORDING-STREAM ^?
686 (with-sheet-medium (medium stream)
687 (when (stream-recording-p stream)
688 (let ((record (make-instance ',class-name
689 :stream stream
690 :ink (medium-ink medium)
691 :clipping-region (medium-clipping-region medium)
692 :transformation (medium-transformation medium)
693 :line-style (medium-line-style medium)
694 :text-style (medium-text-style medium)
695 ,@arg-list)))
696 (stream-add-output-record stream record)))
697 (when (stream-drawing-p stream)
698 (call-next-method))))
699 (defmethod replay-output-record ((record ,class-name) stream
700 &optional (region +everywhere+)
701 (x-offset 0) (y-offset 0))
702 (declare (ignore x-offset y-offset))
703 (with-slots (x1 y1 initial-x1 initial-y1
704 ink clip transform line-style text-style ,@args) record
705 (let ((transformation (compose-translation-with-transformation
706 transform
707 (- x1 initial-x1)
708 (- y1 initial-y1)))
709 (,medium (sheet-medium stream))
710 ;; is sheet a sheet-with-medium-mixin? --GB
711 )
712 (letf (((medium-ink ,medium) ink)
713 ((medium-transformation ,medium) transformation)
714 ((medium-clipping-region ,medium)
715 (region-intersection clip
716 (untransform-region transformation
717 region)))
718 ((medium-line-style ,medium) line-style)
719 ((medium-text-style ,medium) text-style))
720 (,method-name ,medium ,@args))))))))
721
722 (def-grecording draw-point (point-x point-y)
723 (with-transformed-position (transform point-x point-y)
724 (values (- point-x border)
725 (- point-y border)
726 (+ point-x border)
727 (+ point-y border))))
728
729 (def-grecording draw-points (coord-seq)
730 (with-transformed-positions (transform coord-seq)
731 (loop for (x y) on coord-seq by #'cddr
732 minimize x into min-x
733 minimize y into min-y
734 maximize x into max-x
735 maximize y into max-y
736 finally (return (values (- min-x border)
737 (- min-y border)
738 (+ max-x border)
739 (+ max-y border))))))
740
741 (def-grecording draw-line (point-x1 point-y1 point-x2 point-y2)
742 (with-transformed-position (transform point-x1 point-y1)
743 (with-transformed-position (transform point-x2 point-y2)
744 (values (- (min point-x1 point-x2) border)
745 (- (min point-y1 point-y2) border)
746 (+ (max point-x1 point-x2) border)
747 (+ (max point-y1 point-y2) border)))))
748
749 (def-grecording draw-lines (coord-seq)
750 (with-transformed-positions (transform coord-seq)
751 (loop for (x y) on coord-seq by #'cddr
752 minimize x into min-x
753 minimize y into min-y
754 maximize x into max-x
755 maximize y into max-y
756 finally (return (values (- min-x border)
757 (- min-y border)
758 (+ max-x border)
759 (+ max-y border))))))
760
761 (def-grecording draw-polygon (coord-seq closed filled)
762 ;; FIXME !!!
763 ;; If LINE-STYLE-JOINT-SHAPE is :MITTER, then the bb is larger than
764 ;; these numbers by (LINE-THICKNESS / (sin (angle / 2))),
765 ;; which is larger than LINE-THICKNESS
766 (with-transformed-positions (transform coord-seq)
767 (loop for (x y) on coord-seq by #'cddr
768 minimize x into min-x
769 minimize y into min-y
770 maximize x into max-x
771 maximize y into max-y
772 finally (return (if filled
773 (values min-x min-y max-x max-y)
774 (values (- min-x border)
775 (- min-y border)
776 (+ max-x border)
777 (+ max-y border)))))))
778
779 (def-grecording draw-rectangle (left top right bottom filled)
780 ;; FIXME!!! If the rectangle is a line/point, MAKE-RECTANGLE* gives +NOWHERE+,
781 ;; and BOUNDING-RECTANGLE* signals an error.
782 (multiple-value-bind (min-x min-y max-x max-y)
783 (bounding-rectangle* (transform-region transform
784 (make-rectangle*
785 left top right bottom)))
786 (if filled
787 (values min-x min-y max-x max-y)
788 (values (- min-x border)
789 (- min-y border)
790 (+ max-x border)
791 (+ max-y border)))))
792
793 (def-grecording draw-ellipse (center-x center-y
794 radius-1-dx radius-1-dy radius-2-dx radius-2-dy
795 start-angle end-angle filled)
796 (multiple-value-bind (min-x min-y max-x max-y)
797 (bounding-rectangle*
798 (transform-region transform
799 (make-ellipse* center-x center-y
800 radius-1-dx radius-1-dy
801 radius-2-dx radius-2-dy
802 :start-angle start-angle
803 :end-angle end-angle)))
804 (if filled
805 (values min-x min-y max-x max-y)
806 (values (- min-x border)
807 (- min-y border)
808 (+ max-x border)
809 (+ max-y border)))))
810
811 (def-grecording draw-text (string point-x point-y start end
812 align-x align-y toward-x toward-y transform-glyphs)
813 ;; FIXME!!! Text direction.
814 ;; Multiple lines?
815 (let* ((width (stream-string-width stream string
816 :start start :end end
817 :text-style text-style))
818 (ascent (text-style-ascent text-style (sheet-medium stream)))
819 (descent (text-style-descent text-style (sheet-medium stream)))
820 (height (+ ascent descent))
821 left top right bottom)
822 (ecase align-x
823 (:left (setq left point-x
824 right (+ point-x width)))
825 (:right (setq left (- point-x width)
826 right point-x))
827 (:center (setq left (- point-x (round width 2))
828 right (+ point-x (round width 2)))))
829 (ecase align-y
830 (:baseline (setq top (- point-y ascent)
831 bottom (+ point-y descent)))
832 (:top (setq top point-y
833 bottom (+ point-y height)))
834 (:bottom (setq top (- point-y height)
835 bottom point-y))
836 (:center (setq top (- point-y (floor height 2))
837 bottom (+ point-y (ceiling height 2)))))
838 (values left top right bottom)))
839
840 ;;; 16.3.3. Text Displayed Output Record
841 (defvar *drawing-options* (list +foreground-ink+ +everywhere+)
842 "The ink and the clipping region of the current stream.") ; XXX TDO
843
844 (defclass styled-string ()
845 ((start-x :initarg :start-x)
846 (text-style :initarg :text-style)
847 (ink :initarg :ink)
848 (clipping-region :initarg :clipping-region)
849 (string :initarg :string :reader styled-string-string)))
850
851 (defclass standard-text-displayed-output-record
852 (text-displayed-output-record standard-displayed-output-record)
853 ((initial-x1 :initarg :start-x)
854 (initial-y1 :initarg :start-y)
855 (strings :initform nil)
856 (baseline :initform 0)
857 (width :initform 0)
858 (max-height :initform 0)
859 (start-x :initarg :start-x)
860 (start-y :initarg :start-y)
861 (end-x :initarg :start-x)
862 (end-y :initarg :start-y)
863 (wrapped :initform nil
864 :accessor text-record-wrapped)))
865
866 (defmethod print-object ((self standard-text-displayed-output-record) stream)
867 (print-unreadable-object (self stream :type t :identity t)
868 (with-slots (start-x start-y strings) self
869 (format stream "~D,~D ~S"
870 start-x start-y
871 (mapcar #'styled-string-string strings)))))
872
873 (defmethod* (setf output-record-position) :before
874 (nx ny (record standard-text-displayed-output-record))
875 (with-slots (x1 y1 start-x start-y end-x end-y) record
876 (let ((dx (- nx x1))
877 (dy (- ny y1)))
878 (incf start-x dx)
879 (incf start-y dy)
880 (incf end-x dx)
881 (incf end-y dy))))
882
883 (defmethod replay-output-record ((record standard-text-displayed-output-record)
884 stream
885 &optional region (x-offset 0) (y-offset 0))
886 (declare (ignore region x-offset y-offset))
887 (with-slots (strings baseline max-height start-y wrapped
888 x1 y1 initial-x1 initial-y1) record
889 (with-sheet-medium (medium stream) ;is sheet a sheet-with-medium-mixin? --GB
890 ;; XXX Disable recording?
891 (letf (((medium-text-style medium) (make-text-style nil nil nil))
892 ((medium-ink medium) +foreground-ink+)
893 ((medium-clipping-region medium) +everywhere+)
894 ((medium-transformation medium) +identity-transformation+)
895 ((stream-cursor-position stream) (values 0 0))
896 ((slot-value stream 'baseline) baseline)) ; FIXME
897 (loop with offset = (- x1 initial-x1)
898 for substring in strings
899 do (with-slots (start-x text-style ink clipping-region string)
900 substring
901 (setf (stream-cursor-position stream)
902 (values (+ start-x offset) start-y))
903 (setf (medium-text-style medium) text-style
904 (medium-ink medium) ink
905 (medium-clipping-region medium) clipping-region)
906 (stream-write-line stream string)))
907 (when wrapped ; FIXME
908 (draw-rectangle* medium
909 (+ wrapped 0) start-y
910 (+ wrapped 4) (+ start-y max-height)
911 :ink +foreground-ink+
912 :filled t))))))
913
914 (defmethod output-record-start-cursor-position
915 ((record standard-text-displayed-output-record))
916 (with-slots (start-x start-y) record
917 (values start-x start-y)))
918
919 (defmethod output-record-end-cursor-position
920 ((record standard-text-displayed-output-record))
921 (with-slots (end-x end-y) record
922 (values end-x end-y)))
923
924 (defmethod tree-recompute-extent
925 ((text-record standard-text-displayed-output-record))
926 (with-slots (parent x1 y1 x2 y2 width max-height) text-record
927 (setq x2 (coordinate (+ x1 width))
928 y2 (coordinate (+ y1 max-height))))
929 text-record)
930
931 (defmethod add-character-output-to-text-record ; XXX OAOO with ADD-STRING-...
932 ((text-record standard-text-displayed-output-record)
933 character text-style char-width height new-baseline)
934 (destructuring-bind (ink clipping-region) *drawing-options* ; XXX TDO
935 (with-slots (strings baseline width max-height start-y end-x end-y)
936 text-record
937 (if (and strings
938 (let ((string (last1 strings)))
939 (and (eq text-style (slot-value string 'text-style))
940 (eq ink (slot-value string 'ink))
941 (eq clipping-region
942 (slot-value string 'clipping-region)))))
943 (vector-push-extend character (slot-value (last1 strings) 'string))
944 (nconcf strings
945 (list (make-instance
946 'styled-string
947 :start-x end-x
948 :text-style text-style
949 :ink (first *drawing-options*) ; XXX TDO
950 :clipping-region (second *drawing-options*)
951 :string (make-array 1 :initial-element character
952 :element-type 'character
953 :adjustable t
954 :fill-pointer t)))))
955 (setq baseline (max baseline new-baseline)
956 end-x (+ end-x char-width)
957 max-height (max max-height height)
958 end-y (max end-y (+ start-y max-height))
959 width (+ width char-width))))
960 (tree-recompute-extent text-record))
961
962 (defmethod add-string-output-to-text-record
963 ((text-record standard-text-displayed-output-record)
964 string start end text-style string-width height new-baseline)
965 (if end
966 (setq end (min end (length string)))
967 (setq end (length string)))
968 (let ((length (max 0 (- end start))))
969 (cond
970 ((= length 1)
971 (add-character-output-to-text-record text-record
972 (aref string start)
973 text-style
974 string-width height new-baseline))
975 (t
976 (setq string (make-array length :displaced-to string ; XXX
977 :displaced-index-offset start
978 :element-type (array-element-type string)))
979 (with-slots (strings baseline width max-height start-y end-x end-y)
980 text-record
981 (nconcf strings
982 (list (make-instance
983 'styled-string
984 :start-x end-x
985 :text-style text-style
986 :ink (first *drawing-options*) ; XXX TDO
987 :clipping-region (second *drawing-options*)
988 :string (make-array (length string)
989 :initial-contents string
990 :element-type 'character
991 :adjustable t
992 :fill-pointer t))))
993 (setq baseline (max baseline new-baseline)
994 end-x (+ end-x string-width)
995 max-height (max max-height height)
996 end-y (max end-y (+ start-y max-height))
997 width (+ width string-width)))
998 (tree-recompute-extent text-record)))))
999
1000 (defmethod text-displayed-output-record-string
1001 ((record standard-text-displayed-output-record))
1002 (with-output-to-string (result)
1003 (with-slots (strings) record
1004 (loop for (nil nil substring) in strings
1005 do (write-string substring result)))))
1006
1007 ;;; 16.3.4. Top-Level Output Records
1008 (defclass stream-output-history-mixin ()
1009 ())
1010
1011 (defclass standard-sequence-output-history
1012 (standard-sequence-output-record stream-output-history-mixin)
1013 ())
1014
1015 (defclass standard-tree-output-history
1016 (standard-tree-output-record stream-output-history-mixin)
1017 ())
1018
1019 ;;; 16.4. Output Recording Streams
1020 (defclass standard-output-recording-stream (output-recording-stream)
1021 ((recording-p :initform t :reader stream-recording-p)
1022 (drawing-p :initform t :accessor stream-drawing-p)
1023 (output-history :initform (make-instance 'standard-tree-output-history)
1024 :reader stream-output-history)
1025 (current-output-record :accessor stream-current-output-record)
1026 (current-text-output-record :initform nil
1027 :accessor stream-current-text-output-record)
1028 (local-record-p :initform t
1029 :documentation "This flag is used for dealing with streams outputting strings char-by-char.")))
1030
1031 (defmethod initialize-instance :after
1032 ((stream standard-output-recording-stream) &rest args)
1033 (declare (ignore args))
1034 (setf (stream-current-output-record stream) (stream-output-history stream)))
1035
1036 ;;; 16.4.1 The Output Recording Stream Protocol
1037 (defmethod (setf stream-recording-p)
1038 (recording-p (stream standard-output-recording-stream))
1039 (let ((old-val (slot-value stream 'recording-p)))
1040 (setf (slot-value stream 'recording-p) recording-p)
1041 (when (not (eq old-val recording-p))
1042 (stream-close-text-output-record stream))
1043 recording-p))
1044
1045 (defmethod stream-add-output-record
1046 ((stream standard-output-recording-stream) record)
1047 (add-output-record record (stream-current-output-record stream)))
1048
1049 (defmethod stream-replay
1050 ((stream standard-output-recording-stream) &optional region)
1051 (replay (stream-output-history stream) stream region))
1052
1053 (defun output-record-ancestor-p (ancestor child)
1054 (loop for record = child then parent
1055 for parent = (output-record-parent record)
1056 when (eq parent nil) do (return nil)
1057 when (eq parent ancestor) do (return t)))
1058
1059 (defmethod erase-output-record (record (stream standard-output-recording-stream)
1060 &optional (errorp t))
1061 (letf (((stream-recording-p stream) nil))
1062 (let ((region (bounding-rectangle record)))
1063 (with-bounding-rectangle* (x1 y1 x2 y2) region
1064 (if (output-record-ancestor-p (stream-output-history stream) record)
1065 (progn
1066 (delete-output-record record (output-record-parent record))
1067 (draw-rectangle* stream x1 y1 x2 y2 :ink +background-ink+)
1068 (stream-replay stream region))
1069 (when errorp
1070 (error "~S is not contained in ~S." record stream)))))))
1071
1072 (defun copy-textual-output-history (window stream &optional region record)
1073 ;; FIXME
1074 (declare (ignore window stream region record))
1075 (error "Not implemented."))
1076
1077 ;;; 16.4.3. Text Output Recording
1078 (defmethod stream-text-output-record
1079 ((stream standard-output-recording-stream) text-style)
1080 (declare (ignore text-style))
1081 (let ((record (stream-current-text-output-record stream)))
1082 (unless (and record (typep record 'standard-text-displayed-output-record))
1083 (multiple-value-bind (cx cy) (stream-cursor-position stream)
1084 (setf record (make-instance 'standard-text-displayed-output-record
1085 :x-position cx :y-position cy
1086 :start-x cx :start-y cy)
1087 (stream-current-text-output-record stream) record)))
1088 record))
1089
1090 (defmethod stream-close-text-output-record
1091 ((stream standard-output-recording-stream))
1092 (let ((record (stream-current-text-output-record stream)))
1093 (when record
1094 (setf (stream-current-text-output-record stream) nil)
1095 #|record stream-current-cursor-position to (end-x record) - already done|#
1096 (stream-add-output-record stream record))))
1097
1098 (defmethod stream-add-character-output
1099 ((stream standard-output-recording-stream)
1100 character text-style width height baseline)
1101 (add-character-output-to-text-record
1102 (stream-text-output-record stream text-style)
1103 character text-style width height baseline))
1104
1105 (defmethod stream-add-string-output ((stream standard-output-recording-stream)
1106 string start end text-style
1107 width height baseline)
1108 (add-string-output-to-text-record (stream-text-output-record stream
1109 text-style)
1110 string start end text-style
1111 width height baseline))
1112
1113 ;;; Text output catching methods
1114 (defmacro without-local-recording (stream &body body)
1115 `(letf (((slot-value ,stream 'local-record-p) nil))
1116 ,@body))
1117
1118 (defmethod stream-write-line :around
1119 ((stream standard-output-recording-stream) line)
1120 (when (and (stream-recording-p stream)
1121 (slot-value stream 'local-record-p))
1122 (let* ((medium (sheet-medium stream))
1123 (text-style (medium-text-style medium))
1124 (*drawing-options* (list (medium-ink medium) ; XXX TDO
1125 (medium-clipping-region medium))))
1126 (stream-add-string-output stream line 0 nil text-style
1127 (stream-string-width stream line
1128 :text-style text-style)
1129 (text-style-height text-style medium)
1130 (text-style-ascent text-style medium))))
1131 (when (stream-drawing-p stream)
1132 (without-local-recording stream
1133 (call-next-method))))
1134
1135 #+nil
1136 (defmethod stream-write-char :around ((stream standard-output-recording-stream) char)
1137 (when (and (stream-recording-p stream)
1138 (slot-value stream 'local-record-p))
1139 (if (or (eql char #\return)
1140 (eql char #\newline))
1141 (stream-close-text-output-record stream)
1142 (let* ((medium (sheet-medium stream))
1143 (text-style (medium-text-style medium)))
1144 (stream-add-character-output stream char text-style
1145 (stream-character-width stream char :text-style text-style)
1146 (text-style-height text-style medium)
1147 (text-style-ascent text-style medium)))))
1148 (without-local-recording stream
1149 (call-next-method)))
1150
1151 #+nil
1152 (defmethod stream-write-string :around ((stream standard-output-recording-stream) string
1153 &optional (start 0) end)
1154 ;; Problem: it is necessary to check for line wrapping. Now the
1155 ;; default method for STREAM-WRITE-STRING do char-by-char output,
1156 ;; therefore STREAM-WRITE-CHAR can do the right thing.
1157 (when (and (stream-recording-p stream)
1158 (slot-value stream 'local-record-p))
1159 (let* ((medium (sheet-medium stream))
1160 (text-style (medium-text-style medium)))
1161 (stream-add-string-output stream string start end text-style
1162 (stream-string-width stream string
1163 :start start :end end
1164 :text-style text-style)
1165 (text-style-height text-style medium)
1166 (text-style-ascent text-style medium))))
1167 (without-local-recording stream
1168 (call-next-method)))
1169
1170
1171 (defmethod stream-finish-output :after ((stream standard-output-recording-stream))
1172 (stream-close-text-output-record stream))
1173
1174 (defmethod stream-force-output :after ((stream standard-output-recording-stream))
1175 (stream-close-text-output-record stream))
1176
1177 (defmethod stream-terpri :after ((stream standard-output-recording-stream))
1178 (stream-close-text-output-record stream))
1179
1180 (defmethod* (setf stream-cursor-position) :after (x y (stream standard-output-recording-stream))
1181 (declare (ignore x y))
1182 (stream-close-text-output-record stream))
1183
1184 ;(defmethod stream-set-cursor-position :after ((stream standard-output-recording-stream))
1185 ; (stream-close-text-output-record stream))
1186
1187 (defmethod stream-wrap-line :before ((stream standard-output-recording-stream))
1188 (when (stream-recording-p stream)
1189 (setf (text-record-wrapped (stream-text-output-record stream nil)) ; FIXME!
1190 (stream-text-margin stream))))
1191
1192 ;;; 16.4.4. Output Recording Utilities
1193
1194 (defmacro with-output-recording-options ((stream
1195 &key (record nil record-supplied-p)
1196 (draw nil draw-supplied-p))
1197 &body body)
1198 (when (eq stream 't) (setq stream '*standard-output*))
1199 (check-type stream symbol)
1200 (with-gensyms (continuation)
1201 `(flet ((,continuation (,stream) ,@body))
1202 (declare (dynamic-extent #',continuation))
1203 (invoke-with-output-recording-options
1204 ,stream #',continuation
1205 ,(if record-supplied-p record `(stream-recording-p ,stream))
1206 ,(if draw-supplied-p draw `(stream-drawing-p ,stream))))))
1207
1208 (defmethod invoke-with-output-recording-options
1209 ((stream output-recording-stream) continuation record draw)
1210 "Calls CONTINUATION on STREAM enabling or disabling recording and drawing
1211 according to the flags RECORD and DRAW."
1212 (letf (((stream-recording-p stream) record)
1213 ((stream-drawing-p stream) draw))
1214 (funcall continuation stream)))
1215
1216 (defmacro with-new-output-record ((stream
1217 &optional
1218 (record-type 'standard-sequence-output-record)
1219 (record nil record-supplied-p)
1220 &rest initargs)
1221 &body body)
1222 "Creates a new output record of type RECORD-TYPE and then captures
1223 the output of BODY into the new output record, and inserts the new
1224 record into the current \"open\" output record assotiated with STREAM.
1225 If RECORD is supplied, it is the name of a variable that will be
1226 lexically bound to the new output record inside the body. INITARGS are
1227 CLOS initargs that are passed to MAKE-INSTANCE when the new output
1228 record is created.
1229 It returns the created output record.
1230 The STREAM argument is a symbol that is bound to an output
1231 recording stream. If it is T, *STANDARD-OUTPUT* is used."
1232 (when (eq stream 't) (setq stream '*standard-output*))
1233 (check-type stream symbol)
1234 (unless record-supplied-p (setq record (gensym)))
1235 `(invoke-with-new-output-record ,stream
1236 #'(lambda (,stream ,record)
1237 (declare (ignorable ,stream ,record))
1238 ,@body)
1239 ',record-type
1240 ,@initargs))
1241
1242 (defmethod invoke-with-new-output-record ((stream output-recording-stream)
1243 continuation record-type
1244 &rest initargs
1245 &allow-other-keys)
1246 (stream-close-text-output-record stream)
1247 (let ((new-record (apply #'make-instance record-type initargs)))
1248 (letf (((stream-current-output-record stream) new-record))
1249 ;; Should we switch on recording? -- APD
1250 (funcall continuation stream new-record)
1251 (finish-output stream))
1252 (stream-add-output-record stream new-record)
1253 new-record))
1254
1255 (defmacro with-output-to-output-record
1256 ((stream
1257 &optional (record-type 'standard-sequence-output-record)
1258 (record nil record-supplied-p)
1259 &rest initargs)
1260 &body body)
1261 "Creates a new output record of type RECORD-TYPE and then captures
1262 the output of BODY into the new output record. The cursor position of
1263 STREAM is initially bound to (0,0)
1264 If RECORD is supplied, it is the name of a variable that will be
1265 lexically bound to the new output record inside the body. INITARGS are
1266 CLOS initargs that are passed to MAKE-INSTANCE when the new output
1267 record is created.
1268 It returns the created output record.
1269 The STREAM argument is a symbol that is bound to an output
1270 recording stream. If it is T, *STANDARD-OUTPUT* is used."
1271 (when (eq stream 't) (setq stream '*standard-output*))
1272 (check-type stream symbol)
1273 (unless record-supplied-p (setq record (gensym "RECORD")))
1274 `(invoke-with-output-to-output-record
1275 ,stream
1276 #'(lambda (,stream ,record)
1277 (declare (ignorable ,stream ,record))
1278 ,@body)
1279 ',record-type
1280 ,@initargs))
1281
1282 (defmethod invoke-with-output-to-output-record
1283 ((stream output-recording-stream) continuation record-type
1284 &rest initargs
1285 &allow-other-keys)
1286 (stream-close-text-output-record stream)
1287 (let ((new-record (apply #'make-instance record-type initargs)))
1288 (with-output-recording-options (stream :record t :draw nil)
1289 (letf (((stream-current-output-record stream) new-record)
1290 ((stream-cursor-position stream) (values 0 0)))
1291 (funcall continuation stream new-record)
1292 (finish-output stream)))
1293 new-record))
1294
1295 (defmethod make-design-from-output-record (record)
1296 ;; FIXME
1297 (declare (ignore record))
1298 (error "Not implemented."))
1299
1300
1301 ;;; Additional methods
1302 (defmethod scroll-vertical :around ((stream output-recording-stream) dy)
1303 (declare (ignore dy))
1304 (with-output-recording-options (stream :record nil)
1305 (call-next-method)))
1306
1307 (defmethod scroll-horizontal :around ((stream output-recording-stream) dx)
1308 (declare (ignore dx))
1309 (with-output-recording-options (stream :record nil)
1310 (call-next-method)))
1311
1312 (defmethod handle-repaint ((stream output-recording-stream) region)
1313 (stream-replay stream region))
1314
1315 #|
1316 (defmethod handle-event :after ((stream output-recording-stream) (event pointer-button-press-event))
1317 (highlight-output-record (stream-current-output-record stream) stream :highlight))
1318
1319 (defmethod handle-event :before ((stream output-recording-stream) (event pointer-button-release-event))
1320 (highlight-output-record (stream-current-output-record stream) stream :unhighlight))
1321 |#

  ViewVC Help
Powered by ViewVC 1.1.5