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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.63 - (show annotations)
Fri Mar 21 22:07:06 2003 UTC (11 years, 1 month ago) by mikemac
Branch: MAIN
Changes since 1.62: +1 -1 lines
make all code lowercase for ACL's java mode - leave gensyms alone
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 ;;; (Is it still valid?)
31 ;;;
32 ;;; - Redo setf*-output-record-position, extent recomputation for
33 ;;; compound records
34 ;;;
35 ;;; - When DRAWING-P is NIL, should stream cursor move?
36 ;;;
37 ;;; - :{X,Y}-OFFSET.
38 ;;;
39 ;;; - (SETF OUTPUT-RECORD-START-CURSOR-POSITION) does not affect the
40 ;;; bounding rectangle. What does it affect?
41 ;;;
42 ;;; - How should (SETF OUTPUT-RECORD-POSITION) affect the bounding
43 ;;; rectangle of the parent? Now its bounding rectangle is accurately
44 ;;; recomputed, but it is very inefficient for table formatting. It
45 ;;; seems that CLIM is supposed to keep a "large enougn" rectangle and
46 ;;; to shrink it to the correct size only when the layout is complete
47 ;;; by calling TREE-RECOMPUTE-EXTENT.
48 ;;;
49 ;;; - Computation of the bounding rectangle of lines/polygons ignores
50 ;;; LINE-STYLE-CAP-SHAPE.
51 ;;;
52 ;;; - Rounding of coordinates.
53 ;;;
54 ;;; - Document carefully the interface of
55 ;;; STANDARD-OUTPUT-RECORDING-STREAM.
56 ;;;
57 ;;; - COORD-SEQ is a sequence, not a list.
58
59 ;;; Troubles
60
61 ;;; DC
62 ;;;
63 ;;; Some GFs are defined to have "a default method on CLIM's standard
64 ;;; output record class". What does it mean? What is "CLIM's standard
65 ;;; output record class"? Is it OUTPUT-RECORD or BASIC-OUTPUT-RECORD?
66 ;;; Now they are defined on OUTPUT-RECORD.
67
68 ;;; TDO
69 ;;;
70 ;;; Text output record must save ink and clipping region. But its
71 ;;; protocol does not give any way to do it! And a user can put in a
72 ;;; history a record of any class :(. Now we are using
73 ;;; *DRAWING-OPTIONS* to put the necessary information and make sure
74 ;;; that only instances of STANDARD-TEXT-OUTPUT-RECORD are used for
75 ;;; recording. -- APD, 2002-06-15.
76
77 (in-package :clim-internals)
78
79 (define-protocol-class output-record (bounding-rectangle)
80 ())
81
82 (define-protocol-class displayed-output-record (output-record)
83 ())
84
85 ;;; 16.2.1. The Basic Output Record Protocol
86 #+:cmu(declaim (ftype (function (output-record) (values rational rational))
87 output-record-position))
88 (defgeneric output-record-position (record)
89 (:documentation
90 "Returns the x and y position of RECORD. The position is the
91 position of the upper-left corner of its bounding rectangle. The
92 position is relative to the stream, where (0,0) is (initially) the
93 upper-left corner of the stream."))
94
95 (defgeneric* (setf output-record-position) (x y record)
96 (:documentation
97 "Changes the x and y position of the RECORD to be X and Y, and
98 updates the bounding rectangle to reflect the new position (and saved
99 cursor positions, if the output record stores it). If RECORD has any
100 children, all of the children (and their descendants as well) will be
101 moved by the same amount as RECORD was moved. The bounding rectangles
102 of all of RECORD's ancestors will also be updated to be large enough
103 to contain RECORD."))
104
105 #+:cmu(declaim (ftype (function (output-record) (values integer integer))
106 output-record-start-cursor-position))
107 (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 (defgeneric* (setf output-record-start-cursor-position) (x y record))
114
115 #+:cmu(declaim (ftype (function (output-record) (values integer integer))
116 output-record-end-cursor-position))
117 (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 (defgeneric* (setf output-record-end-cursor-position) (x y record))
124
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 (defgeneric (setf output-record-parent) (parent record)
131 (:documentation "Non-standard function."))
132
133 (defgeneric replay-output-record (record stream
134 &optional region x-offset y-offset)
135 (:documentation "Displays the output captured by RECORD on the
136 STREAM, exactly as it was originally captured. The current user
137 transformation, line style, text style, ink and clipping region of
138 STREAM are all ignored. Instead, these are gotten from the output
139 record.
140
141 Only those records that overlap REGION are displayed."))
142
143 (defgeneric output-record-hit-detection-rectangle* (record))
144
145 (defgeneric output-record-refined-position-test (record x y))
146
147 (defgeneric highlight-output-record (record stream state))
148
149 (defgeneric displayed-output-record-ink (displayed-output-record))
150
151 ;;; 16.2.2. Output Record "Database" Protocol
152
153 (defgeneric output-record-children (record))
154
155 (defgeneric add-output-record (child record))
156
157 (defgeneric delete-output-record (child record &optional errorp))
158
159 (defgeneric clear-output-record (record))
160
161 (defgeneric output-record-count (record))
162
163 (defgeneric map-over-output-records-containing-position
164 (function record x y &optional x-offset y-offset &rest function-args)
165 (:documentation "Maps over all of the children of RECORD that
166 contain the point at (X,Y), calling FUNCTION on each one. FUNCTION is
167 a function of one or more arguments, the first argument being the
168 record containing the point. FUNCTION is also called with all of
169 FUNCTION-ARGS as APPLY arguments.
170
171 If there are multiple records that contain the point,
172 MAP-OVER-OUTPUT-RECORDS-CONTAINING-POSITION hits the most recently
173 inserted record first and the least recently inserted record
174 last. Otherwise, the order in which the records are traversed is
175 unspecified."))
176
177 (defgeneric map-over-output-records-overlapping-region
178 (function record region &optional x-offset y-offset &rest function-args)
179 (:documentation "Maps over all of the children of the RECORD that
180 overlap the REGION, calling FUNCTION on each one. FUNCTION is a
181 function of one or more arguments, the first argument being the record
182 overlapping the region. FUNCTION is also called with all of
183 FUNCTION-ARGS as APPLY arguments.
184
185 If there are multiple records that overlap the region and that overlap
186 each other, MAP-OVER-OUTPUT-RECORDS-OVERLAPPING-REGION hits the least
187 recently inserted record first and the most recently inserted record
188 last. Otherwise, the order in which the records are traversed is
189 unspecified. "))
190
191 ;;; From the Franz CLIM user's guide but not in the spec... clearly necessary.
192 ;;; What is its status? -- APD, 2002-06-14.
193 (defgeneric map-over-output-records
194 (continuation record &optional x-offset y-offset &rest continuation-args))
195
196 ;;; 16.2.3. Output Record Change Notification Protocol
197
198 (defgeneric recompute-extent-for-new-child (record child))
199
200 (defgeneric recompute-extent-for-changed-child
201 (record child old-min-x old-min-y old-max-x old-max-y))
202
203 (defgeneric tree-recompute-extent (record))
204
205 ;;; 16.3. Types of Output Records
206 (define-protocol-class graphics-displayed-output-record
207 (displayed-output-record)
208 ())
209
210 (define-protocol-class text-displayed-output-record (displayed-output-record)
211 ())
212
213 ;;; 16.3.3. Text Displayed Output Record
214 (defgeneric add-character-output-to-text-record
215 (text-record character text-style width height baseline))
216
217 (defgeneric add-string-output-to-text-record
218 (text-record string start end text-style width height baseline))
219
220 (defgeneric text-displayed-output-record-string (text-record))
221
222 ;;; 16.4. Output Recording Streams
223 (define-protocol-class output-recording-stream ()
224 ())
225
226 ;;; 16.4.1. The Output Recording Stream Protocol
227 (defgeneric stream-recording-p (stream))
228
229 (defgeneric (setf stream-recording-p) (recording-p stream))
230
231 (defgeneric stream-drawing-p (stream))
232
233 (defgeneric (setf stream-drawing-p) (drawing-p stream))
234
235 (defgeneric stream-output-history (stream))
236
237 (defgeneric stream-current-output-record (stream))
238
239 (defgeneric (setf stream-current-output-record) (record stream))
240
241 (defgeneric stream-add-output-record (stream record))
242
243 (defgeneric stream-replay (stream &optional region))
244
245 (defgeneric erase-output-record (record stream &optional errorp))
246
247 ;;; 16.4.3. Text Output Recording
248 (defgeneric stream-text-output-record (stream text-style))
249
250 (defgeneric stream-close-text-output-record (stream))
251
252 (defgeneric stream-add-character-output
253 (stream character text-style width height baseline))
254
255 (defgeneric stream-add-string-output
256 (stream string start end text-style width height baseline))
257
258 ;;; 16.4.4. Output Recording Utilities
259 (defgeneric invoke-with-output-recording-options
260 (stream continuation record draw))
261
262 (defgeneric invoke-with-new-output-record (stream continuation record-type
263 &rest initargs
264 &key
265 &allow-other-keys))
266
267 (defgeneric invoke-with-output-to-output-record
268 (stream continuation record-type
269 &rest initargs
270 &key
271 &allow-other-keys))
272
273 (defgeneric make-design-from-output-record (record))
274
275 ;;; 21.3 Incremental Redisplay Protocol. These generic functions need
276 ;;; to be implemented for all the basic displayed-output-records, so they are
277 ;;; defined in this file.
278
279 (defgeneric match-output-records (record &rest args))
280
281 (defgeneric match-output-records-1 (record &key)
282 (:method-combination and :most-specific-last))
283
284 ;;; Macros
285 (defmacro with-output-recording-options ((stream
286 &key (record nil record-supplied-p)
287 (draw nil draw-supplied-p))
288 &body body)
289 (when (eq stream 't) (setq stream '*standard-output*))
290 (check-type stream symbol)
291 (with-gensyms (continuation)
292 `(flet ((,continuation (,stream)
293 (declare (ignorable ,stream))
294 ,@body))
295 (declare (dynamic-extent #',continuation))
296 (invoke-with-output-recording-options
297 ,stream #',continuation
298 ,(if record-supplied-p record `(stream-recording-p ,stream))
299 ,(if draw-supplied-p draw `(stream-drawing-p ,stream))))))
300
301 (defmacro with-new-output-record ((stream
302 &optional
303 (record-type ''standard-sequence-output-record)
304 (record nil record-supplied-p)
305 &rest initargs)
306 &body body)
307 "Creates a new output record of type RECORD-TYPE and then captures
308 the output of BODY into the new output record, and inserts the new
309 record into the current \"open\" output record assotiated with STREAM.
310 If RECORD is supplied, it is the name of a variable that will be
311 lexically bound to the new output record inside the body. INITARGS are
312 CLOS initargs that are passed to MAKE-INSTANCE when the new output
313 record is created.
314 It returns the created output record.
315 The STREAM argument is a symbol that is bound to an output
316 recording stream. If it is T, *STANDARD-OUTPUT* is used."
317 (when (eq stream 't) (setq stream '*standard-output*))
318 (check-type stream symbol)
319 (unless record-supplied-p (setq record (gensym)))
320 `(invoke-with-new-output-record ,stream
321 #'(lambda (,stream ,record)
322 (declare (ignorable ,stream ,record))
323 ,@body)
324 ,record-type
325 ,@initargs))
326
327 (defmacro with-output-to-output-record
328 ((stream
329 &optional (record-type ''standard-sequence-output-record)
330 (record nil record-supplied-p)
331 &rest initargs)
332 &body body)
333 "Creates a new output record of type RECORD-TYPE and then captures
334 the output of BODY into the new output record. The cursor position of
335 STREAM is initially bound to (0,0)
336 If RECORD is supplied, it is the name of a variable that will be
337 lexically bound to the new output record inside the body. INITARGS are
338 CLOS initargs that are passed to MAKE-INSTANCE when the new output
339 record is created.
340 It returns the created output record.
341 The STREAM argument is a symbol that is bound to an output
342 recording stream. If it is T, *STANDARD-OUTPUT* is used."
343 (when (eq stream 't) (setq stream '*standard-output*))
344 (check-type stream symbol)
345 (unless record-supplied-p (setq record (gensym "RECORD")))
346 `(invoke-with-output-to-output-record
347 ,stream
348 #'(lambda (,stream ,record)
349 (declare (ignorable ,stream ,record))
350 ,@body)
351 ,record-type
352 ,@initargs))
353
354
355 ;;;; Implementation
356
357 (defclass basic-output-record (standard-bounding-rectangle output-record)
358 ((parent :initarg :parent ; XXX
359 :initform nil
360 :accessor output-record-parent)) ; XXX
361 (:documentation "Implementation class for the Basic Output Record Protocol."))
362
363 (defmethod initialize-instance :after ((record basic-output-record)
364 &rest args
365 &key (x-position 0) (y-position 0))
366 (declare (ignore args))
367 (with-slots (x1 y1 x2 y2) record
368 (setq x1 x-position
369 y1 y-position
370 x2 x-position
371 y2 y-position)))
372
373 (defclass compound-output-record (basic-output-record)
374 ((x :initarg :x-position
375 :initform 0
376 :documentation "X-position of the empty record.")
377 (y :initarg :y-position
378 :initform 0
379 :documentation "Y-position of the empty record.")
380 (in-moving-p :initform nil
381 :documentation "Is set while changing the position."))
382 (:documentation "Implementation class for output records with children."))
383
384 ;;; 16.2.1. The Basic Output Record Protocol
385 (defmethod output-record-position ((record basic-output-record))
386 (bounding-rectangle-position record))
387
388 (defmethod* (setf output-record-position) (nx ny (record basic-output-record))
389 (with-slots (x1 y1 x2 y2) record
390 (let ((dx (- nx x1))
391 (dy (- ny y1)))
392 (setf x1 nx y1 ny
393 x2 (+ x2 dx) y2 (+ y2 dy))))
394 (values nx ny))
395
396 (defmethod* (setf output-record-position) :around
397 (nx ny (record basic-output-record))
398 (with-bounding-rectangle* (min-x min-y max-x max-y) record
399 (call-next-method)
400 (let ((parent (output-record-parent record)))
401 (when parent
402 (recompute-extent-for-changed-child parent record
403 min-x min-y max-x max-y))))
404 (values nx ny))
405
406 (defmethod* (setf output-record-position) :before
407 (nx ny (record compound-output-record))
408 (with-slots (x1 y1 in-moving-p) record
409 (letf ((in-moving-p t))
410 (let ((dx (- nx x1))
411 (dy (- ny y1)))
412 (map-over-output-records
413 (lambda (child)
414 (multiple-value-bind (x y) (output-record-position child)
415 (setf (output-record-position child)
416 (values (+ x dx) (+ y dy)))))
417 record)))))
418
419 (defmethod output-record-start-cursor-position ((record basic-output-record))
420 (values nil nil))
421
422 (defmethod* (setf output-record-start-cursor-position)
423 (x y (record basic-output-record))
424 (values x y))
425
426 (defmethod output-record-end-cursor-position ((record basic-output-record))
427 (values nil nil))
428
429 (defmethod* (setf output-record-end-cursor-position)
430 (x y (record basic-output-record))
431 (values x y))
432
433 #+cmu
434 (progn
435 ;; Sometimes CMU's PCL fails with forward reference classes, so this
436 ;; is a kludge to keep it happy.
437 ;;
438 ;; This was reported as a bug to cmucl-imp [<E18vKN1-0004DQ-00@saphir.local>]
439 ;;
440 ;; In short it exposes itself when you compile and load into a
441 ;; _virgin_ lisp the following:
442 ;;
443 ;; (defclass foo (bar) ())
444 ;; (defun barz () (make-instance 'foo))
445 ;; (defclass bar () ())
446 ;;
447 ;; --GB 2003-03-18
448 ;;
449 (defclass gs-ink-mixin () ())
450 (defclass gs-clip-mixin () ())
451 (defclass gs-line-style-mixin () ())
452 (defclass gs-text-style-mixin () ()))
453
454 ;;; Humph. It'd be nice to tie this to the actual definition of a
455 ;;; medium. -- moore
456 (defclass complete-medium-state
457 (gs-ink-mixin gs-clip-mixin gs-line-style-mixin gs-text-style-mixin)
458 ())
459
460 (defun replay (record stream &optional region)
461 (stream-close-text-output-record stream)
462 (when (stream-drawing-p stream)
463 (with-cursor-off stream
464 (letf (((stream-cursor-position stream) (values 0 0))
465 ((stream-recording-p stream) nil)
466 ;; Is there a better value to bind to baseline?
467 ((slot-value stream 'baseline) (slot-value stream 'baseline)))
468 (with-sheet-medium (medium stream)
469 (let ((medium-state (make-instance 'complete-medium-state
470 :medium medium)))
471 (unwind-protect
472 (progn
473 (setf (medium-transformation medium)
474 +identity-transformation+)
475 (replay-output-record record stream region))
476 (set-medium-graphics-state medium-state medium))))))))
477
478
479 (defmethod replay-output-record ((record compound-output-record) stream
480 &optional region (x-offset 0) (y-offset 0))
481 (when (null region)
482 (let ((viewport (pane-viewport stream)))
483 (cond ((not (null viewport))
484 (setf region (untransform-region (sheet-delta-transformation stream viewport)
485 (pane-viewport-region stream))))
486 (t
487 (setq region +everywhere+)))))
488 (with-drawing-options (stream :clipping-region region)
489 (map-over-output-records-overlapping-region
490 #'replay-output-record record region x-offset y-offset
491 stream region x-offset y-offset)))
492
493 (defmethod output-record-hit-detection-rectangle* ((record output-record))
494 ;; XXX DC
495 (bounding-rectangle* record))
496
497 (defmethod output-record-refined-position-test ((record basic-output-record)
498 x y)
499 (declare (ignore x y))
500 t)
501
502 ;;; XXX Should this only be defined on recording streams?
503 (defmethod highlight-output-record ((record output-record)
504 stream state)
505 ;; XXX DC
506 ;; XXX Disable recording?
507 (letf (((medium-transformation stream) +identity-transformation+))
508 (multiple-value-bind (x1 y1 x2 y2)
509 (output-record-hit-detection-rectangle* record)
510 (ecase state
511 (:highlight
512 (draw-rectangle* (sheet-medium stream) x1 y1 x2 y2
513 :filled nil :ink +foreground-ink+)) ; XXX +FLIPPING-INK+?
514 (:unhighlight
515 (draw-rectangle* (sheet-medium stream) x1 y1 x2 y2
516 :filled nil :ink +background-ink+)))))) ; XXX +FLIPPING-INK+?
517
518 ;;; 16.2.2. The Output Record "Database" Protocol
519 (defmethod output-record-children ((record basic-output-record))
520 nil)
521
522 (defmethod add-output-record (child (record basic-output-record))
523 (declare (ignore child))
524 (error "Cannot add a child to ~S." record))
525
526 (defmethod add-output-record :before (child (record compound-output-record))
527 (let ((parent (output-record-parent child)))
528 (when parent
529 (restart-case
530 (error "~S already has a parent ~S." child parent)
531 (delete ()
532 :report "Delete from the old parent."
533 (delete-output-record child parent))))))
534
535 (defmethod add-output-record :after (child (record compound-output-record))
536 (recompute-extent-for-new-child record child))
537
538 (defmethod delete-output-record (child (record basic-output-record)
539 &optional (errorp t))
540 (declare (ignore child))
541 (when errorp (error "Cannot delete a child from ~S." record)))
542
543 (defmethod delete-output-record :after (child (record compound-output-record)
544 &optional (errorp t))
545 (declare (ignore errorp))
546 (with-bounding-rectangle* (x1 y1 x2 y2) child
547 (recompute-extent-for-changed-child record child x1 y1 x2 y2)))
548
549 (defmethod clear-output-record ((record basic-output-record))
550 (error "Cannot clear ~S." record))
551
552 (defmethod clear-output-record :after ((record compound-output-record))
553 (with-slots (x y x1 y1 x2 y2) record
554 (setf x1 x y1 y
555 x2 x y2 y)))
556
557 (defmethod output-record-count ((record basic-output-record))
558 0)
559
560 (defmethod map-over-output-records
561 (function (record basic-output-record)
562 &optional (x-offset 0) (y-offset 0)
563 &rest function-args)
564 (declare (ignore function x-offset y-offset function-args))
565 nil)
566
567 ;;; This needs to work in "most recently added last" order. Is this
568 ;;; implementation right? -- APD, 2002-06-13
569 #+nil
570 (defmethod map-over-output-records
571 (function (record compound-output-record)
572 &optional (x-offset 0) (y-offset 0)
573 &rest function-args)
574 (declare (ignore x-offset y-offset))
575 (map nil (lambda (child) (apply function child function-args))
576 (output-record-children record)))
577
578 (defmethod map-over-output-records-containing-position
579 (function (record basic-output-record) x y
580 &optional (x-offset 0) (y-offset 0)
581 &rest function-args)
582 (declare (ignore function x y x-offset y-offset function-args))
583 nil)
584
585 ;;; This needs to work in "most recently added first" order. Is this
586 ;;; implementation right? -- APD, 2002-06-13
587 #+nil
588 (defmethod map-over-output-records-containing-position
589 (function (record compound-output-record) x y
590 &optional (x-offset 0) (y-offset 0)
591 &rest function-args)
592 (declare (ignore x-offset y-offset))
593 (map nil
594 (lambda (child)
595 (when (and (multiple-value-bind (min-x min-y max-x max-y)
596 (output-record-hit-detection-rectangle* child)
597 (and (<= min-x x max-x) (<= min-y y max-y)))
598 (output-record-refined-position-test child x y))
599 (apply function child function-args)))
600 (output-record-children record)))
601
602 (defmethod map-over-output-records-overlapping-region
603 (function (record basic-output-record) region
604 &optional (x-offset 0) (y-offset 0)
605 &rest function-args)
606 (declare (ignore function region x-offset y-offset function-args))
607 nil)
608
609 ;;; This needs to work in "most recently added last" order. Is this
610 ;;; implementation right? -- APD, 2002-06-13
611 #+nil
612 (defmethod map-over-output-records-overlapping-region
613 (function (record compound-output-record) region
614 &optional (x-offset 0) (y-offset 0)
615 &rest function-args)
616 (declare (ignore x-offset y-offset))
617 (map nil
618 (lambda (child) (when (region-intersects-region-p region child)
619 (apply function child function-args)))
620 (output-record-children record)))
621
622 ;;; 16.2.3. Output Record Change Notification Protocol
623 (defmethod recompute-extent-for-new-child
624 ((record compound-output-record) child)
625 (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2) record
626 (with-slots (parent x1 y1 x2 y2) record
627 (if (= 1 (length (output-record-children record)))
628 (setf (values x1 y1 x2 y2) (bounding-rectangle* child))
629 (with-bounding-rectangle* (x1-child y1-child x2-child y2-child) child
630 (minf x1 x1-child)
631 (minf y1 y1-child)
632 (maxf x2 x2-child)
633 (maxf y2 y2-child)))
634 (when parent
635 (recompute-extent-for-changed-child parent record
636 old-x1 old-y1 old-x2 old-y2))))
637 record)
638
639 (defmethod %tree-recompute-extent* ((record compound-output-record))
640 ;; Internal helper function
641 (let ((new-x1 0)
642 (new-y1 0)
643 (new-x2 0)
644 (new-y2 0)
645 (first-time t))
646 (map-over-output-records
647 (lambda (child)
648 (if first-time
649 (progn
650 (multiple-value-setq (new-x1 new-y1 new-x2 new-y2)
651 (bounding-rectangle* child))
652 (setq first-time nil))
653 (with-bounding-rectangle* (cx1 cy1 cx2 cy2) child
654 (minf new-x1 cx1)
655 (minf new-y1 cy1)
656 (maxf new-x2 cx2)
657 (maxf new-y2 cy2))))
658 record)
659 (if first-time
660 (with-slots (x y) record
661 (values x y x y))
662 (values new-x1 new-y1 new-x2 new-y2))))
663
664 (defmethod recompute-extent-for-changed-child
665 ((record compound-output-record) changed-child
666 old-min-x old-min-y old-max-x old-max-y)
667 ;; If the child's old and new bbox lies entirely within the record's bbox
668 ;; then no change need be made to the record's bbox. Otherwise, if some part
669 ;; of the child's bbox was on the record's bbox and is now inside, examine
670 ;; all the children to determine the correct new bbox.
671 (with-slots (x1 y1 x2 y2) record
672 (with-bounding-rectangle* (child-x1 child-y1 child-x2 child-y2)
673 changed-child
674 (unless (and (> x1 old-min-x) (> x1 child-x1)
675 (> y1 old-min-y) (> y1 child-y1)
676 (< x2 old-max-x) (< x2 child-x2)
677 (< y2 old-max-y) (< y2 child-y2))
678 ;; Don't know if changed-child has been deleted or what, so go through
679 ;; all the children and construct the updated bbox.
680 (setf (values x1 y1 x2 y2) (%tree-recompute-extent* record)))))
681 record)
682
683 (defmethod recompute-extent-for-changed-child :around
684 ((record compound-output-record) child
685 old-min-x old-min-y old-max-x old-max-y)
686 (declare (ignore child old-min-x old-min-y old-max-x old-max-y))
687 (unless (slot-value record 'in-moving-p)
688 (let ((old-rectangle (multiple-value-call #'make-bounding-rectangle
689 (bounding-rectangle* record))))
690 (call-next-method)
691 (with-slots (parent x1 y1 x2 y2) record
692 (when (and parent (not (region-equal old-rectangle record)))
693 (multiple-value-call #'recompute-extent-for-changed-child
694 (values parent record)
695 (bounding-rectangle* old-rectangle))))))
696 record)
697
698 (defmethod tree-recompute-extent ((record compound-output-record))
699 (with-slots (x1 y1 x2 y2) record
700 (setf (values x1 y1 x2 y2) (%tree-recompute-extent* record)))
701 record)
702
703 (defmethod tree-recompute-extent :around ((record compound-output-record))
704 (let ((old-rectangle (multiple-value-call #'make-bounding-rectangle
705 (bounding-rectangle* record))))
706 (call-next-method)
707 (with-slots (parent x1 y1 x2 y2) record
708 (when (and parent (not (region-equal old-rectangle record)))
709 (recompute-extent-for-changed-child parent record x1 y1 x2 y2))))
710 record)
711
712 ;;; 16.3.1. Standard output record classes
713
714 (defclass standard-sequence-output-record (compound-output-record)
715 ((children :initform (make-array 8 :adjustable t :fill-pointer 0)
716 :reader output-record-children)))
717
718 (defmethod add-output-record (child (record standard-sequence-output-record))
719 (vector-push-extend child (output-record-children record))
720 (setf (output-record-parent child) record))
721
722 (defmethod delete-output-record (child (record standard-sequence-output-record)
723 &optional (errorp t))
724 (with-slots (children) record
725 (let ((pos (position child children :test #'eq)))
726 (if (null pos)
727 (when errorp
728 (error "~S is not a child of ~S" child record))
729 (progn
730 (setq children (replace children children
731 :start1 pos
732 :start2 (1+ pos)))
733 (decf (fill-pointer children))
734 (setf (output-record-parent child) nil))))))
735
736 (defmethod clear-output-record ((record standard-sequence-output-record))
737 (let ((children (output-record-children record)))
738 (map 'nil (lambda (child) (setf (output-record-parent child) nil))
739 children)
740 (fill children nil)
741 (setf (fill-pointer children) 0)))
742
743 (defmethod output-record-count ((record standard-sequence-output-record))
744 (length (output-record-children record)))
745
746 (defmethod map-over-output-records
747 (function (record standard-sequence-output-record)
748 &optional (x-offset 0) (y-offset 0)
749 &rest function-args)
750 "Applies FUNCTION to all children in the order they were added."
751 (declare (ignore x-offset y-offset))
752 (loop with children = (output-record-children record)
753 for child across children
754 do (apply function child function-args)))
755
756 (defmethod map-over-output-records-containing-position
757 (function (record standard-sequence-output-record) x y
758 &optional (x-offset 0) (y-offset 0)
759 &rest function-args)
760 "Applies FUNCTION to children, containing (X,Y), in the reversed
761 order they were added."
762 (declare (ignore x-offset y-offset))
763 (loop with children = (output-record-children record)
764 for i from (1- (length children)) downto 0
765 for child = (aref children i)
766 when (and (multiple-value-bind (min-x min-y max-x max-y)
767 (output-record-hit-detection-rectangle* child)
768 (and (<= min-x x max-x) (<= min-y y max-y)))
769 (output-record-refined-position-test child x y))
770 do (apply function child function-args)))
771
772 (defmethod map-over-output-records-overlapping-region
773 (function (record standard-sequence-output-record) region
774 &optional (x-offset 0) (y-offset 0)
775 &rest function-args)
776 "Applies FUNCTION to children, overlapping REGION, in the order they
777 were added."
778 (declare (ignore x-offset y-offset))
779 (loop with children = (output-record-children record)
780 for child across children
781 when (region-intersects-region-p region child)
782 do (apply function child function-args)))
783
784 ;;; XXX bogus for now.
785 (defclass standard-tree-output-record (standard-sequence-output-record)
786 (
787 ))
788
789 (defmethod match-output-records ((record t) &rest args)
790 (apply #'match-output-records-1 record args))
791
792 ;;; Factor out the graphics state portions of the output records so
793 ;;; they can be manipulated seperately e.g., by incremental
794 ;;; display. The individual slots of a graphics state are factored into mixin
795 ;;; classes so that each output record can capture only the state that it needs.
796 ;;; -- moore
797
798 ;;; It would be appealing to define a setf method, e.g. (setf
799 ;;; medium-graphics-state), for setting a medium's state from a graphics state
800 ;;; object, but that would require us to define a medium-graphics-state reader
801 ;;; that would cons a state object. I don't want to do that.
802
803 (defclass graphics-state ()
804 ()
805 (:documentation "Stores those parts of the medium/stream graphics state
806 that need to be restored when drawing an output record"))
807
808 (defgeneric set-medium-graphics-state (state medium)
809 (:documentation "Sets the MEDIUM graphics state from STATE"))
810
811 (defmethod set-medium-graphics-state (state medium)
812 (declare (ignore medium))
813 state)
814
815 (defmethod set-medium-graphics-state (state (stream output-recording-stream))
816 (with-sheet-medium (medium stream)
817 (set-medium-graphics-state state medium)))
818
819 (defclass gs-ink-mixin (graphics-state)
820 ((ink :initarg :ink :accessor graphics-state-ink)))
821
822 (defmethod initialize-instance :after ((obj gs-ink-mixin)
823 &key (stream nil)
824 (medium (when stream
825 (sheet-medium stream))))
826 (when (and medium (not (slot-boundp obj 'ink)))
827 (setf (slot-value obj 'ink) (medium-ink medium))))
828
829 (defmethod set-medium-graphics-state :after ((state gs-ink-mixin) medium)
830 (setf (medium-ink medium) (graphics-state-ink state)))
831
832 (defmethod match-output-records-1 and ((record gs-ink-mixin)
833 &key (ink nil inkp))
834 (or (null inkp)
835 (design-equalp (graphics-state-ink record) ink)))
836
837 (defclass gs-clip-mixin (graphics-state)
838 ((clip :initarg :clipping-region :accessor graphics-state-clip
839 :documentation "Clipping region in stream coordinates.")))
840
841
842 (defmethod initialize-instance :after ((obj gs-clip-mixin)
843 &key (stream nil)
844 (medium (when stream
845 (sheet-medium stream))))
846 (when medium
847 (with-slots (clip)
848 obj
849 (let ((clip-region (if (slot-boundp obj 'clip)
850 (region-intersection (medium-clipping-region
851 medium)
852 clip)
853 (medium-clipping-region medium))))
854 (setq clip (transform-region (medium-transformation medium)
855 clip-region))))))
856
857 (defmethod set-medium-graphics-state :after ((state gs-clip-mixin) medium)
858 ;;
859 ;; This definition is kind of wrong. When output records are about to
860 ;; be replayed only a certain region of the stream should be affected.[1]
861 ;; Therefore I disabled this code, since this way only breaks the
862 ;; [not very frequent case] that the output record actually contains
863 ;; a clipping region different from +everywhere+, while having it in
864 ;; breaks redisplay of streams in just about every case.
865 ;;
866 ;; Most notably Closure is affected by this, as it does the equivalent of
867 ;; (draw-rectangle* medium 0 0 800 200 :ink +white+ :filled t)
868 ;; (draw-text* medium "Hello" 100 100)
869 ;;
870 ;; Having this code in a redisplay on the region
871 ;; (make-rectangle* 0 0 50 50) fills the drawing pane with a white
872 ;; rectangle obscuring the text.
873 ;;
874 ;; [1] it is of course debatable where this extra clipping because
875 ;; of redisplay should come from. Should replay-output-record set it
876 ;; up? Should handle-repaint do so?
877 ;;
878 ;; --GB 2003-03-14
879 #+nil
880 (setf (medium-clipping-region medium) (graphics-state-clip state)))
881
882 (defmethod match-output-records-1 and ((record gs-clip-mixin)
883 &key (clip nil clipp))
884 (or clipp
885 (region-equal (graphics-state-clip record) clip)))
886
887 ;;; 16.3.2. Graphics Displayed Output Records
888 (defclass standard-displayed-output-record (gs-clip-mixin gs-ink-mixin
889 basic-output-record
890 displayed-output-record)
891 ((ink :reader displayed-output-record-ink))
892 (:documentation "Implementation class for DISPLAYED-OUTPUT-RECORD."))
893
894 (defclass gs-line-style-mixin (graphics-state)
895 ((line-style :initarg :line-style :accessor graphics-state-line-style)))
896
897 (defmethod initialize-instance :after ((obj gs-line-style-mixin)
898 &key (stream nil)
899 (medium (when stream
900 (sheet-medium stream))))
901 (when medium
902 (unless (slot-boundp obj 'line-style)
903 (setf (slot-value obj 'line-style) (medium-line-style medium)))))
904
905 (defmethod set-medium-graphics-state :after ((state gs-line-style-mixin) medium)
906 (setf (medium-line-style medium) (graphics-state-line-style state)))
907
908 (defmethod match-output-records-1 and ((record gs-line-style-mixin)
909 &key (line-style nil line-style-p))
910 (or (null line-style-p)
911 (line-style-equalp (graphics-state-line-style record) line-style)))
912
913 (defgeneric graphics-state-line-style-border (record medium)
914 (:method ((record gs-line-style-mixin) medium)
915 (/ (line-style-effective-thickness (graphics-state-line-style record)
916 medium)
917 2)))
918
919 (defclass gs-text-style-mixin (graphics-state)
920 ((text-style :initarg :text-style :accessor graphics-state-text-style)))
921
922 (defmethod initialize-instance :after ((obj gs-text-style-mixin)
923 &key (stream nil)
924 (medium (when stream
925 (sheet-medium stream))))
926 (when medium
927 (unless (slot-boundp obj 'text-style)
928 (setf (slot-value obj 'text-style) (medium-text-style medium)))))
929
930 (defmethod set-medium-graphics-state :after ((state gs-text-style-mixin) medium)
931 (setf (medium-text-style medium) (graphics-state-text-style state)))
932
933 (defmethod match-output-records-1 and ((record gs-text-style-mixin)
934 &key (text-style nil text-style-p))
935 (or (null text-style-p)
936 (text-style-equalp (graphics-state-text-style record) text-style)))
937
938 (defclass standard-graphics-displayed-output-record
939 (standard-displayed-output-record
940 graphics-displayed-output-record)
941 ())
942
943 (defmethod match-output-records-1 and
944 ((record standard-displayed-output-record)
945 &key (x1 nil x1-p) (y1 nil y1-p)
946 (x2 nil x2-p) (y2 nil y2-p)
947 (bounding-rectangle nil bounding-rectangle-p))
948 (if bounding-rectangle-p
949 (region-equal record bounding-rectangle)
950 (multiple-value-bind (my-x1 my-y1 my-x2 my-y2)
951 (bounding-rectangle* record)
952 (and (or (null x1-p) (coordinate= my-x1 x1))
953 (or (null y1-p) (coordinate= my-y1 y1))
954 (or (null x2-p) (coordinate= my-x2 x2))
955 (or (null y2-p) (coordinate= my-y2 y2))))))
956
957 ;;; This is an around method so that more specific before methods can be
958 ;;; defined for the various mixin classes, that modify the state after it has
959 ;;; been set in the graphics state.
960
961 (defmethod replay-output-record :around
962 ((record standard-displayed-output-record) stream
963 &optional region x-offset y-offset)
964 (declare (ignore region x-offset y-offset))
965 (set-medium-graphics-state record stream)
966 (call-next-method))
967
968 (defclass coord-seq-mixin ()
969 ((coord-seq :accessor coord-seq :initarg :coord-seq))
970 (:documentation "Mixin class that implements methods for records that contain
971 sequences of coordinates."))
972
973 (defun coord-seq-bounds (coord-seq border)
974 (let* ((min-x (elt coord-seq 0))
975 (min-y (elt coord-seq 1))
976 (max-x min-x)
977 (max-y min-y))
978 (do-sequence ((x y) coord-seq)
979 (minf min-x x)
980 (minf min-y y)
981 (maxf max-x x)
982 (maxf max-y y))
983 (values (- min-x border) (- min-y border)
984 (+ max-x border) (+ max-y border))))
985
986 (defmethod initialize-instance :after ((record coord-seq-mixin) &key)
987 (let ((medium (sheet-medium (slot-value record 'stream))))
988 (with-slots (coord-seq)
989 record
990 (setf coord-seq
991 (transform-position-sequence 'vector
992 (medium-transformation medium)
993 coord-seq)))))
994
995 ;;; x1, y1 slots must exist in class...
996
997 (defmethod* (setf output-record-position) :around
998 (nx ny (record coord-seq-mixin))
999 (with-slots (x1 y1)
1000 record
1001 (let ((dx (- nx x1))
1002 (dy (- ny y1))
1003 (coords (slot-value record 'coord-seq)))
1004 (multiple-value-prog1
1005 (call-next-method)
1006 (loop for i from 0 below (length coords) by 2
1007 do (progn
1008 (incf (aref coords i) dx)
1009 (incf (aref coords (1+ i)) dy)))))))
1010
1011 (defmethod match-output-records-1 and ((record coord-seq-mixin)
1012 &key (coord-seq nil coord-seq-p))
1013 (or (null coord-seq-p)
1014 (let* ((my-coord-seq (slot-value record 'coord-seq))
1015 (len (length my-coord-seq)))
1016 (and (eql len (length coord-seq))
1017 (loop for elt1 across my-coord-seq
1018 for elt2 across coord-seq
1019 always (coordinate= elt1 elt2))))))
1020
1021 ;;; Do we need to save/restore graphics state in each call to
1022 ;;; replay-output-record, or could we do it only in replay? I'd like to save
1023 ;;; state in a graphics state object, but I'm not going to allocate one in each
1024 ;;; recursive invocation of replay-output-record :P -- moore
1025
1026 (defmacro def-grecording (name ((&rest mixins) &rest args) &body body)
1027 (let ((method-name (symbol-concat '#:medium- name '*))
1028 (class-name (symbol-concat name '#:-output-record))
1029 (medium (gensym "MEDIUM"))
1030 (class-vars `((stream :initarg :stream)
1031 ,@(loop for arg in args
1032 collect `(,arg
1033 :initarg ,(intern (symbol-name arg)
1034 :keyword)))))
1035 (arg-list (loop for arg in args
1036 nconc `(,(intern (symbol-name arg) :keyword) ,arg))))
1037 `(progn
1038 (defclass ,class-name (,@mixins standard-graphics-displayed-output-record)
1039 ,class-vars)
1040 (defmethod initialize-instance :after ((graphic ,class-name) &rest args)
1041 (declare (ignore args))
1042 (with-slots (x1 y1 x2 y2
1043 stream ink clipping-region
1044 line-style text-style ,@args)
1045 graphic
1046 (let* ((medium (sheet-medium stream)))
1047 (multiple-value-setq (x1 y1 x2 y2) (progn ,@body)))))
1048 (defmethod ,method-name :around ((stream output-recording-stream) ,@args)
1049 ;; XXX STANDARD-OUTPUT-RECORDING-STREAM ^?
1050 (with-sheet-medium (medium stream)
1051 (when (stream-recording-p stream)
1052 (let ((record (make-instance ',class-name
1053 :stream stream
1054 ,@arg-list)))
1055 (stream-add-output-record stream record)))
1056 (when (stream-drawing-p stream)
1057 (call-next-method))))
1058 (defmethod replay-output-record ((record ,class-name) stream
1059 &optional (region +everywhere+)
1060 (x-offset 0) (y-offset 0))
1061 (declare (ignore x-offset y-offset region))
1062 (with-slots (,@args) record
1063 (let ((,medium (sheet-medium stream))
1064 ;; is sheet a sheet-with-medium-mixin? --GB
1065 )
1066 ;; Graphics state is set up in :around method.
1067 (,method-name ,medium ,@args)))))))
1068
1069 (def-grecording draw-point ((gs-line-style-mixin) point-x point-y)
1070 (let ((border (graphics-state-line-style-border graphic medium)))
1071 (with-transformed-position ((medium-transformation medium) point-x point-y)
1072 (setf (slot-value graphic 'point-x) point-x
1073 (slot-value graphic 'point-y) point-y)
1074 (values (- point-x border)
1075 (- point-y border)
1076 (+ point-x border)
1077 (+ point-y border)))))
1078
1079 (defmethod* (setf output-record-position) :around
1080 (nx ny (record draw-point-output-record))
1081 (with-slots (x1 y1 point-x point-y)
1082 record
1083 (let ((dx (- nx x1))
1084 (dy (- ny y1)))
1085 (multiple-value-prog1
1086 (call-next-method)
1087 (incf point-x dx)
1088 (incf point-y dy)))))
1089
1090 (defmethod match-output-records-1 and ((record draw-point-output-record)
1091 &key (point-x nil point-x-p)
1092 (point-y nil point-y-p))
1093 (and (or (null point-x-p)
1094 (coordinate= (slot-value record 'point-x) point-x))
1095 (or (null point-y-p)
1096 (coordinate= (slot-value record 'point-y) point-y))))
1097
1098
1099 (def-grecording draw-points ((coord-seq-mixin gs-line-style-mixin) coord-seq)
1100 ;; coord-seq has already been transformed
1101 (let ((border (graphics-state-line-style-border graphic medium)))
1102 (coord-seq-bounds coord-seq border)))
1103
1104 (def-grecording draw-line ((gs-line-style-mixin)
1105 point-x1 point-y1 point-x2 point-y2)
1106 (let ((transform (medium-transformation medium))
1107 (border (graphics-state-line-style-border graphic medium)))
1108 (with-transformed-position (transform point-x1 point-y1)
1109 (with-transformed-position (transform point-x2 point-y2)
1110 (setf (slot-value graphic 'point-x1) point-x1
1111 (slot-value graphic 'point-y1) point-y1
1112 (slot-value graphic 'point-x2) point-x2
1113 (slot-value graphic 'point-y2) point-y2)
1114 (values (- (min point-x1 point-x2) border)
1115 (- (min point-y1 point-y2) border)
1116 (+ (max point-x1 point-x2) border)
1117 (+ (max point-y1 point-y2) border))))))
1118
1119 (defmethod* (setf output-record-position) :around
1120 (nx ny (record draw-line-output-record))
1121 (with-slots (x1 y1
1122 point-x1 point-y1 point-x2 point-y2)
1123 record
1124 (let ((dx (- nx x1))
1125 (dy (- ny y1)))
1126 (multiple-value-prog1
1127 (call-next-method)
1128 (incf point-x1 dx)
1129 (incf point-y1 dy)
1130 (incf point-x2 dx)
1131 (incf point-y2 dy)))))
1132
1133 (defmethod match-output-records-1 and ((record draw-line-output-record)
1134 &key (point-x1 nil point-x1-p)
1135 (point-y1 nil point-y1-p)
1136 (point-x2 nil point-x2-p)
1137 (point-y2 nil point-y2-p))
1138 (and (or (null point-x1-p)
1139 (coordinate= (slot-value record 'point-x1) point-x1))
1140 (or (null point-y1-p)
1141 (coordinate= (slot-value record 'point-y1) point-y1))
1142 (or (null point-x2-p)
1143 (coordinate= (slot-value record 'point-x2) point-x2))
1144 (or (null point-y2-p)
1145 (coordinate= (slot-value record 'point-y2) point-y2))))
1146
1147
1148 (def-grecording draw-lines ((coord-seq-mixin gs-line-style-mixin) coord-seq)
1149 (let ((border (graphics-state-line-style-border graphic medium)))
1150 (coord-seq-bounds coord-seq border)))
1151
1152 ;;; Helper function
1153 (defun normalize-coords (dx dy &optional unit)
1154 (let ((norm (sqrt (+ (* dx dx) (* dy dy)))))
1155 (if unit
1156 (let ((scale (/ unit norm)))
1157 (values (* dx scale) (* dy scale)))
1158 (values (/ dx norm) (/ dy norm)))))
1159
1160 (defun polygon-record-bounding-rectangle
1161 (coord-seq closed filled line-style border miter-limit)
1162 (cond (filled
1163 (coord-seq-bounds coord-seq 0))
1164 ((eq (line-style-joint-shape line-style) :round)
1165 (coord-seq-bounds coord-seq border))
1166 (t (let* ((x1 (svref coord-seq 0))
1167 (y1 (svref coord-seq 1))
1168 (min-x x1)
1169 (min-y y1)
1170 (max-x x1)
1171 (max-y y1)
1172 (len (length coord-seq)))
1173 (unless closed
1174 (setq min-x (- x1 border) min-y (- y1 border)
1175 max-x (+ x1 border) max-y (+ y1 border)))
1176 ;; Setup for iterating over the coordinate vector. If the polygon
1177 ;; is closed deal with the extra segment.
1178 (multiple-value-bind (initial-xp initial-yp
1179 final-xn final-yn
1180 initial-index final-index)
1181 (if closed
1182 (values (svref coord-seq (- len 2))
1183 (svref coord-seq (- len 1))
1184 x1 y1
1185 0 (- len 2))
1186 (values x1 y1
1187 (svref coord-seq (- len 2))
1188 (svref coord-seq (- len 1))
1189 2 (- len 4)))
1190 (ecase (line-style-joint-shape line-style)
1191 (:miter
1192 ;;FIXME: Remove successive positively proportional segments
1193 (loop with sin-limit = (sin (* 0.5 miter-limit))
1194 and xn and yn
1195 for i from initial-index to final-index by 2
1196 for xp = initial-xp then x
1197 for yp = initial-yp then y
1198 for x = (svref coord-seq i)
1199 for y = (svref coord-seq (1+ i))
1200 do (setf (values xn yn)
1201 (if (eql i final-index)
1202 (values final-xn final-yn)
1203 (values (svref coord-seq (+ i 2))
1204 (svref coord-seq (+ i
1205 3)))))
1206 (multiple-value-bind (ex1 ey1)
1207 (normalize-coords (- x xp) (- y yp))
1208 (multiple-value-bind (ex2 ey2)
1209 (normalize-coords (- x xn) (- y yn))
1210 (let* ((cos-a (+ (* ex1 ex2) (* ey1 ey2)))
1211 (sin-a/2 (sqrt (* 0.5 (- 1.0 cos-a)))))
1212 (if (< sin-a/2 sin-limit)
1213 (let ((nx (* border
1214 (max (abs ey1) (abs ey2))))
1215 (ny (* border
1216 (max (abs ex1) (abs ex2)))))
1217 (minf min-x (- x nx))
1218 (minf min-y (- y ny))
1219 (maxf max-x (+ x nx))
1220 (maxf max-y (+ y ny)))
1221 (let ((length (/ border sin-a/2)))
1222 (multiple-value-bind (dx dy)
1223 (normalize-coords (+ ex1 ex2)
1224 (+ ey1 ey2)
1225 length)
1226 (minf min-x (+ x dx))
1227 (minf min-y (+ y dy))
1228 (maxf max-x (+ x dx))
1229 (maxf max-y (+ y dy))))))))))
1230 ((:bevel :none)
1231 (loop with xn and yn
1232 for i from initial-index to final-index by 2
1233 for xp = initial-xp then x
1234 for yp = initial-yp then y
1235 for x = (svref coord-seq i)
1236 for y = (svref coord-seq (1+ i))
1237 do (setf (values xn yn)
1238 (if (eql i final-index)
1239 (values final-xn final-yn)
1240 (values (svref coord-seq (+ i 2))
1241 (svref coord-seq (+ i
1242 3)))))
1243 (multiple-value-bind (ex1 ey1)
1244 (normalize-coords (- x xp) (- y yp))
1245 (multiple-value-bind (ex2 ey2)
1246 (normalize-coords (- x xn) (- y yn))
1247 (let ((nx (* border (max (abs ey1) (abs ey2))))
1248 (ny (* border (max (abs ex1) (abs ex2)))))
1249 (minf min-x (- x nx))
1250 (minf min-y (- y ny))
1251 (maxf max-x (+ x nx))
1252 (maxf max-y (+ y ny))))))))
1253 (unless closed
1254 (multiple-value-bind (x y)
1255 (values (svref coord-seq final-index)
1256 (svref coord-seq (1+ final-index)))
1257 (minf min-x (- x border))
1258 (minf min-y (- y border))
1259 (maxf max-x (+ x border))
1260 (maxf max-y (+ y border)))))
1261 (values min-x min-y max-x max-y)))))
1262
1263 (def-grecording draw-polygon ((coord-seq-mixin gs-line-style-mixin)
1264 coord-seq closed filled)
1265 (let ((border (graphics-state-line-style-border graphic medium)))
1266 (polygon-record-bounding-rectangle
1267 coord-seq closed filled line-style border (medium-miter-limit medium))))
1268
1269 (defmethod match-output-records-1 and ((record draw-polygon-output-record)
1270 &key (closed nil closedp)
1271 (filled nil filledp))
1272 (and (or (null closedp)
1273 (eql (slot-value record 'closed) closed))
1274 (or (null filledp)
1275 (eql (slot-value record 'filled) filled))))
1276
1277 (def-grecording draw-rectangle ((gs-line-style-mixin)
1278 left top right bottom filled)
1279 (let ((border (graphics-state-line-style-border graphic medium)))
1280 (polygon-record-bounding-rectangle
1281 (vector left top left bottom right bottom right top)
1282 t filled line-style border
1283 (medium-miter-limit medium))))
1284
1285 (defmethod* (setf output-record-position) :around
1286 (nx ny (record draw-rectangle-output-record))
1287 (with-slots (x1 y1
1288 left top right bottom)
1289 record
1290 (let ((dx (- nx x1))
1291 (dy (- ny y1)))
1292 (multiple-value-prog1
1293 (call-next-method)
1294 (incf left dx)
1295 (incf top dy)
1296 (incf right dx)
1297 (incf bottom dy)))))
1298
1299 (defmethod match-output-records-1 and ((record draw-rectangle-output-record)
1300 &key (left nil leftp)
1301 (top nil topp)
1302 (right nil rightp)
1303 (bottom nil bottomp)
1304 (filled nil filledp))
1305 (and (or (null leftp)
1306 (coordinate= (slot-value record 'left) left))
1307 (or (null topp)
1308 (coordinate= (slot-value record 'top) top))
1309 (or (null rightp)
1310 (coordinate= (slot-value record 'right) right))
1311 (or (null bottomp)
1312 (coordinate= (slot-value record 'bottom) bottom))
1313 (or (null filledp)
1314 (eql (slot-value record 'filled) filled))))
1315
1316 (def-grecording draw-ellipse ((gs-line-style-mixin)
1317 center-x center-y
1318 radius-1-dx radius-1-dy radius-2-dx radius-2-dy
1319 start-angle end-angle filled)
1320 (multiple-value-bind (min-x min-y max-x max-y)
1321 (bounding-rectangle* (make-ellipse* center-x center-y
1322 radius-1-dx radius-1-dy
1323 radius-2-dx radius-2-dy
1324 :start-angle start-angle
1325 :end-angle end-angle))
1326 (if filled
1327 (values min-x min-y max-x max-y)
1328 (let ((border (graphics-state-line-style-border graphic medium)))
1329 (values (- min-x border)
1330 (- min-y border)
1331 (+ max-x border)
1332 (+ max-y border))))))
1333
1334 (defmethod* (setf output-record-position) :around
1335 (nx ny (record draw-ellipse-output-record))
1336 (with-slots (x1 y1 center-x center-y)
1337 record
1338 (let ((dx (- nx x1))
1339 (dy (- ny y1)))
1340 (multiple-value-prog1
1341 (call-next-method)
1342 (incf center-x dx)
1343 (incf center-y dy)))))
1344
1345 (defmethod match-output-records-1 and ((record draw-ellipse-output-record)
1346 &key (center-x nil center-x-p)
1347 (center-y nil center-y-p))
1348 (and (or (null center-x-p)
1349 (coordinate= (slot-value record 'center-x) center-x))
1350 (or (null center-y-p)
1351 (coordinate= (slot-value record 'center-y) center-y))))
1352
1353 (def-grecording draw-text ((gs-text-style-mixin) string point-x point-y start end
1354 align-x align-y toward-x toward-y transform-glyphs)
1355 ;; FIXME!!! Text direction.
1356 ;; Multiple lines?
1357 (let* ((text-style (graphics-state-text-style graphic))
1358 (width (stream-string-width stream string
1359 :start start :end end
1360 :text-style text-style))
1361 (ascent (text-style-ascent text-style (sheet-medium stream)))
1362 (descent (text-style-descent text-style (sheet-medium stream)))
1363 (height (+ ascent descent))
1364 left top right bottom)
1365 (ecase align-x
1366 (:left (setq left point-x
1367 right (+ point-x width)))
1368 (:right (setq left (- point-x width)
1369 right point-x))
1370 (:center (setq left (- point-x (round width 2))
1371 right (+ point-x (round width 2)))))
1372 (ecase align-y
1373 (:baseline (setq top (- point-y ascent)
1374 bottom (+ point-y descent)))
1375 (:top (setq top point-y
1376 bottom (+ point-y height)))
1377 (:bottom (setq top (- point-y height)
1378 bottom point-y))
1379 (:center (setq top (- point-y (floor height 2))
1380 bottom (+ point-y (ceiling height 2)))))
1381 (values left top right bottom)))
1382
1383 (defmethod* (setf output-record-position) :around
1384 (nx ny (record draw-text-output-record))
1385 (with-slots (x1 y1 point-x point-y toward-x toward-y)
1386 record
1387 (let ((dx (- nx x1))
1388 (dy (- ny y1)))
1389 (multiple-value-prog1
1390 (call-next-method)
1391 (incf point-x dx)
1392 (incf point-y dy)
1393 (incf toward-x dx)
1394 (incf toward-y dy)))))
1395
1396 (defmethod match-output-records-1 and ((record draw-text-output-record)
1397 &key (string nil stringp)
1398 (start nil startp)
1399 (end nil endp)
1400 (point-x nil point-x-p)
1401 (point-y nil point-y-p)
1402 (align-x nil align-x-p)
1403 (align-y nil align-y-p)
1404 (toward-x nil toward-x-p)
1405 (toward-y nil toward-y-p)
1406 (transform-glyphs nil
1407 transform-glyphs-p))
1408 (and (or (null stringp)
1409 (string= (slot-value record 'string) string))
1410 (or (null startp)
1411 (eql (slot-value record 'start) start))
1412 (or (null endp)
1413 (eql (slot-value record 'end) end))
1414 (or (null point-x-p)
1415 (coordinate= (slot-value record 'point-x) point-x))
1416 (or (null point-y-p)
1417 (coordinate= (slot-value record 'point-y) point-y))
1418 (or (null align-x-p)
1419 (eq (slot-value record 'align-x) align-x))
1420 (or (null align-y-p)
1421 (eq (slot-value record 'align-y) align-y))
1422 (or (null toward-x-p)
1423 (coordinate= (slot-value record 'toward-x) toward-x))
1424 (or (null toward-y-p)
1425 (coordinate= (slot-value record 'toward-y) toward-y))
1426 (or (null transform-glyphs-p)
1427 (eq (slot-value record 'transform-glyphs) transform-glyphs))))
1428
1429 ;;; 16.3.3. Text Displayed Output Record
1430 (defvar *drawing-options* (list +foreground-ink+ +everywhere+)
1431 "The ink and the clipping region of the current stream.") ; XXX TDO
1432
1433 (defclass styled-string (gs-text-style-mixin gs-clip-mixin gs-ink-mixin)
1434 ((start-x :initarg :start-x)
1435 (string :initarg :string :reader styled-string-string)))
1436
1437 (defclass standard-text-displayed-output-record
1438 (text-displayed-output-record standard-displayed-output-record)
1439 ((initial-x1 :initarg :start-x)
1440 (initial-y1 :initarg :start-y)
1441 (strings :initform nil)
1442 (baseline :initform 0)
1443 (width :initform 0)
1444 (max-height :initform 0)
1445 (start-x :initarg :start-x)
1446 (start-y :initarg :start-y)
1447 (end-x :initarg :start-x)
1448 (end-y :initarg :start-y)
1449 (wrapped :initform nil
1450 :accessor text-record-wrapped)
1451 (medium :initarg :medium :initform nil)))
1452
1453 (defmethod initialize-instance :after
1454 ((obj standard-text-displayed-output-record) &key stream)
1455 (when stream
1456 (setf (slot-value obj 'medium) (sheet-medium stream))))
1457
1458 (defmethod print-object ((self standard-text-displayed-output-record) stream)
1459 (print-unreadable-object (self stream :type t :identity t)
1460 (with-slots (start-x start-y strings) self
1461 (format stream "~D,~D ~S"
1462 start-x start-y
1463 (mapcar #'styled-string-string strings)))))
1464
1465 (defmethod* (setf output-record-position) :before
1466 (nx ny (record standard-text-displayed-output-record))
1467 (with-slots (x1 y1 start-x start-y end-x end-y strings) record
1468 (let ((dx (- nx x1))
1469 (dy (- ny y1)))
1470 (incf start-x dx)
1471 (incf start-y dy)
1472 (incf end-x dx)
1473 (incf end-y dy)
1474 (loop for s in strings
1475 do (incf (slot-value s 'start-x) dx)))))
1476
1477 (defmethod replay-output-record ((record standard-text-displayed-output-record)
1478 stream
1479 &optional region (x-offset 0) (y-offset 0))
1480 (declare (ignore region x-offset y-offset))
1481 (with-slots (strings baseline max-height start-y wrapped x1 y1)
1482 record
1483 (with-sheet-medium (medium stream) ;is sheet a sheet-with-medium-mixin? --GB
1484 ;; FIXME:
1485 ;; 1. SLOT-VALUE...
1486 ;; 2. It should also save a "current line".
1487 (setf (slot-value stream 'baseline) baseline)
1488 (loop for substring in strings
1489 do (with-slots (start-x string)
1490 substring
1491 (setf (stream-cursor-position stream)
1492 (values start-x start-y))
1493 (set-medium-graphics-state substring medium)
1494 (stream-write-line stream string)))
1495 (when wrapped ; FIXME
1496 (draw-rectangle* medium
1497 (+ wrapped 0) start-y
1498 (+ wrapped 4) (+ start-y max-height)
1499 :ink +foreground-ink+
1500 :filled t)))))
1501
1502 (defmethod output-record-start-cursor-position
1503 ((record standard-text-displayed-output-record))
1504 (with-slots (start-x start-y) record
1505 (values start-x start-y)))
1506
1507 (defmethod output-record-end-cursor-position
1508 ((record standard-text-displayed-output-record))
1509 (with-slots (end-x end-y) record
1510 (values end-x end-y)))
1511
1512 (defmethod tree-recompute-extent
1513 ((text-record standard-text-displayed-output-record))
1514 (with-slots (parent x1 y1 x2 y2 width max-height) text-record
1515 (setq x2 (coordinate (+ x1 width))
1516 y2 (coordinate (+ y1 max-height))))
1517 text-record)
1518
1519 (defmethod add-character-output-to-text-record ; XXX OAOO with ADD-STRING-...
1520 ((text-record standard-text-displayed-output-record)
1521 character text-style char-width height new-baseline)
1522 (with-slots (strings baseline width max-height start-y end-x end-y medium)
1523 text-record
1524 (if (and strings
1525 (let ((string (last1 strings)))
1526 (match-output-records string
1527 :text-style text-style
1528 :ink (medium-ink medium)
1529 :clipping-region (medium-clipping-region
1530 medium))))
1531 (vector-push-extend character (slot-value (last1 strings) 'string))
1532 (nconcf strings
1533 (list (make-instance
1534 'styled-string
1535 :start-x end-x
1536 :text-style text-style
1537 :medium medium ; pick up ink and clipping region
1538 :string (make-array 1 :initial-element character
1539 :element-type 'character
1540 :adjustable t
1541 :fill-pointer t)))))
1542 (setq baseline (max baseline new-baseline)
1543 end-x (+ end-x char-width)
1544 max-height (max max-height height)
1545 end-y (max end-y (+ start-y max-height))
1546 width (+ width char-width)))
1547 (tree-recompute-extent text-record))
1548
1549 (defmethod add-string-output-to-text-record
1550 ((text-record standard-text-displayed-output-record)
1551 string start end text-style string-width height new-baseline)
1552 (if end
1553 (setq end (min end (length string)))
1554 (setq end (length string)))
1555 (let ((length (max 0 (- end start))))
1556 (cond
1557 ((eql length 1)
1558 (add-character-output-to-text-record text-record
1559 (aref string start)
1560 text-style
1561 string-width height new-baseline))
1562 (t (with-slots (strings baseline width max-height start-y end-x end-y
1563 medium)
1564 text-record
1565 (let ((styled-string (make-instance
1566 'styled-string
1567 :start-x end-x
1568 :text-style text-style
1569 :medium medium
1570 :string (make-array (length string)
1571 :element-type 'character
1572 :adjustable t
1573 :fill-pointer t))))
1574 (nconcf strings (list styled-string))
1575 (replace (styled-string-string styled-string) string
1576 :start2 start :end2 end))
1577 (setq baseline (max baseline new-baseline)
1578 end-x (+ end-x string-width)
1579 max-height (max max-height height)
1580 end-y (max end-y (+ start-y max-height))
1581 width (+ width string-width)))
1582 (tree-recompute-extent text-record)))))
1583
1584 (defmethod text-displayed-output-record-string
1585 ((record standard-text-displayed-output-record))
1586 (with-output-to-string (result)
1587 (with-slots (strings) record
1588 (loop for (nil nil substring) in strings
1589 do (write-string substring result)))))
1590
1591 ;;; 16.3.4. Top-Level Output Records
1592 (defclass stream-output-history-mixin ()
1593 ())
1594
1595 (defclass standard-sequence-output-history
1596 (standard-sequence-output-record stream-output-history-mixin)
1597 ())
1598
1599 (defclass standard-tree-output-history
1600 (standard-tree-output-record stream-output-history-mixin)
1601 ())
1602
1603 ;;; 16.4. Output Recording Streams
1604 (defclass standard-output-recording-stream (output-recording-stream)
1605 ((recording-p :initform t :reader stream-recording-p)
1606 (drawing-p :initform t :accessor stream-drawing-p)
1607 (output-history :initform (make-instance 'standard-tree-output-history)
1608 :reader stream-output-history)
1609 (current-output-record :accessor stream-current-output-record)
1610 (current-text-output-record :initform nil
1611 :accessor stream-current-text-output-record)
1612 (local-record-p :initform t
1613 :documentation "This flag is used for dealing with streams outputting strings char-by-char.")))
1614
1615 (defmethod initialize-instance :after
1616 ((stream standard-output-recording-stream) &rest args)
1617 (declare (ignore args))
1618 (setf (stream-current-output-record stream) (stream-output-history stream)))
1619
1620 ;;; Used in initializing clim-stream-pane
1621
1622 (defmethod reset-output-history ((stream
1623 standard-output-recording-stream))
1624 (setf (slot-value stream 'output-history)
1625 (make-instance 'standard-tree-output-history))
1626 (setf (stream-current-output-record stream) (stream-output-history stream)))
1627
1628 ;;; 16.4.1 The Output Recording Stream Protocol
1629 (defmethod (setf stream-recording-p)
1630 (recording-p (stream standard-output-recording-stream))
1631 (let ((old-val (slot-value stream 'recording-p)))
1632 (setf (slot-value stream 'recording-p) recording-p)
1633 (when (not (eq old-val recording-p))
1634 (stream-close-text-output-record stream))
1635 recording-p))
1636
1637 (defmethod stream-add-output-record
1638 ((stream standard-output-recording-stream) record)
1639 (add-output-record record (stream-current-output-record stream)))
1640
1641 (defmethod stream-replay
1642 ((stream standard-output-recording-stream) &optional region)
1643 (replay (stream-output-history stream) stream region))
1644
1645 (defun output-record-ancestor-p (ancestor child)
1646 (loop for record = child then parent
1647 for parent = (output-record-parent record)
1648 when (eq parent nil) do (return nil)
1649 when (eq parent ancestor) do (return t)))
1650
1651 (defmethod erase-output-record (record (stream standard-output-recording-stream)
1652 &optional (errorp t))
1653 (letf (((stream-recording-p stream) nil))
1654 (let ((region (bounding-rectangle record)))
1655 (with-bounding-rectangle* (x1 y1 x2 y2) region
1656 (if (output-record-ancestor-p (stream-output-history stream) record)
1657 (progn
1658 (delete-output-record record (output-record-parent record))
1659 (with-output-recording-options (stream :record nil)
1660 (draw-rectangle* stream x1 y1 x2 y2 :ink +background-ink+))
1661 (stream-replay stream region))
1662 (when errorp
1663 (error "~S is not contained in ~S." record stream)))))))
1664
1665 (defun copy-textual-output-history (window stream &optional region record)
1666 ;; FIXME
1667 (declare (ignore window stream region record))
1668 (error "Not implemented."))
1669
1670 ;;; 16.4.3. Text Output Recording
1671 (defmethod stream-text-output-record
1672 ((stream standard-output-recording-stream) text-style)
1673 (declare (ignore text-style))
1674 (let ((record (stream-current-text-output-record stream)))
1675 (unless (and record (typep record 'standard-text-displayed-output-record))
1676 (multiple-value-bind (cx cy) (stream-cursor-position stream)
1677 (setf record (make-instance 'standard-text-displayed-output-record
1678 :x-position cx :y-position cy
1679 :start-x cx :start-y cy
1680 :stream stream)
1681 (stream-current-text-output-record stream) record)))
1682 record))
1683
1684 (defmethod stream-close-text-output-record
1685 ((stream standard-output-recording-stream))
1686 (let ((record (stream-current-text-output-record stream)))
1687 (when record
1688 (setf (stream-current-text-output-record stream) nil)
1689 #|record stream-current-cursor-position to (end-x record) - already done|#
1690 (stream-add-output-record stream record))))
1691
1692 (defmethod stream-add-character-output
1693 ((stream standard-output-recording-stream)
1694 character text-style width height baseline)
1695 (add-character-output-to-text-record
1696 (stream-text-output-record stream text-style)
1697 character text-style width height baseline))
1698
1699 (defmethod stream-add-string-output ((stream standard-output-recording-stream)
1700 string start end text-style
1701 width height baseline)
1702 (add-string-output-to-text-record (stream-text-output-record stream
1703 text-style)
1704 string start end text-style
1705 width height baseline))
1706
1707 ;;; Text output catching methods
1708 (defmacro without-local-recording (stream &body body)
1709 `(letf (((slot-value ,stream 'local-record-p) nil))
1710 ,@body))
1711
1712 (defmethod stream-write-line :around
1713 ((stream standard-output-recording-stream) line)
1714 (when (and (stream-recording-p stream)
1715 (slot-value stream 'local-record-p))
1716 (let* ((medium (sheet-medium stream))
1717 (text-style (medium-text-style medium))
1718 (*drawing-options* (list (medium-ink medium) ; XXX TDO
1719 (medium-clipping-region medium))))
1720 (stream-add-string-output stream line 0 nil text-style
1721 (stream-string-width stream line
1722 :text-style text-style)
1723 (text-style-height text-style medium)
1724 (text-style-ascent text-style medium))))
1725 (when (stream-drawing-p stream)
1726 (without-local-recording stream
1727 (call-next-method))))
1728
1729 #+nil
1730 (defmethod stream-write-char :around ((stream standard-output-recording-stream) char)
1731 (when (and (stream-recording-p stream)
1732 (slot-value stream 'local-record-p))
1733 (if (or (eql char #\return)
1734
1735 (stream-close-text-output-record stream)
1736 (let* ((medium (sheet-medium stream))
1737 (text-style (medium-text-style medium)))
1738 (stream-add-character-output stream char text-style
1739 (stream-character-width stream char :text-style text-style)
1740 (text-style-height text-style medium)
1741 (text-style-ascent text-style medium)))))
1742 (without-local-recording stream
1743 (call-next-method))))
1744
1745 #+nil
1746 (defmethod stream-write-string :around ((stream standard-output-recording-stream) string
1747 &optional (start 0) end)
1748 ;; Problem: it is necessary to check for line wrapping. Now the
1749 ;; default method for STREAM-WRITE-STRING do char-by-char output,
1750 ;; therefore STREAM-WRITE-CHAR can do the right thing.
1751 (when (and (stream-recording-p stream)
1752 (slot-value stream 'local-record-p))
1753 (let* ((medium (sheet-medium stream))
1754 (text-style (medium-text-style medium)))
1755 (stream-add-string-output stream string start end text-style
1756 (stream-string-width stream string
1757 :start start :end end
1758 :text-style text-style)
1759 (text-style-height text-style medium)
1760 (text-style-ascent text-style medium))))
1761 (without-local-recording stream
1762 (call-next-method)))
1763
1764
1765 (defmethod stream-finish-output :after ((stream standard-output-recording-stream))
1766 (stream-close-text-output-record stream))
1767
1768 (defmethod stream-force-output :after ((stream standard-output-recording-stream))
1769 (stream-close-text-output-record stream))
1770
1771 (defmethod stream-terpri :after ((stream standard-output-recording-stream))
1772 (stream-close-text-output-record stream))
1773
1774 (defmethod* (setf stream-cursor-position) :after (x y (stream standard-output-recording-stream))
1775 (declare (ignore x y))
1776 (stream-close-text-output-record stream))
1777
1778 ;(defmethod stream-set-cursor-position :after ((stream standard-output-recording-stream))
1779 ; (stream-close-text-output-record stream))
1780
1781 (defmethod stream-wrap-line :before ((stream standard-output-recording-stream))
1782 (when (stream-recording-p stream)
1783 (setf (text-record-wrapped (stream-text-output-record stream nil)) ; FIXME!
1784 (stream-text-margin stream))))
1785
1786 ;;; 16.4.4. Output Recording Utilities
1787
1788 (defmethod invoke-with-output-recording-options
1789 ((stream output-recording-stream) continuation record draw)
1790 "Calls CONTINUATION on STREAM enabling or disabling recording and drawing
1791 according to the flags RECORD and DRAW."
1792 (letf (((stream-recording-p stream) record)
1793 ((stream-drawing-p stream) draw))
1794 (funcall continuation stream)))
1795
1796 (defmethod invoke-with-new-output-record ((stream output-recording-stream)
1797 continuation record-type
1798 &rest initargs
1799 &key
1800 &allow-other-keys)
1801 (stream-close-text-output-record stream)
1802 (let ((new-record (apply #'make-instance record-type initargs)))
1803 (letf (((stream-current-output-record stream) new-record))
1804 ;; Should we switch on recording? -- APD
1805 (funcall continuation stream new-record)
1806 (finish-output stream))
1807 (stream-add-output-record stream new-record)
1808 new-record))
1809
1810 (defmethod invoke-with-output-to-output-record
1811 ((stream output-recording-stream) continuation record-type
1812 &rest initargs
1813 &key
1814 &allow-other-keys)
1815 (stream-close-text-output-record stream)
1816 (let ((new-record (apply #'make-instance record-type initargs)))
1817 (with-output-recording-options (stream :record t :draw nil)
1818 (letf (((stream-current-output-record stream) new-record)
1819 ((stream-cursor-position stream) (values 0 0)))
1820 (funcall continuation stream new-record)
1821 (finish-output stream)))
1822 new-record))
1823
1824 (defmethod make-design-from-output-record (record)
1825 ;; FIXME
1826 (declare (ignore record))
1827 (error "Not implemented."))
1828
1829
1830 ;;; Additional methods
1831 (defmethod scroll-vertical :around ((stream output-recording-stream) dy)
1832 (declare (ignore dy))
1833 (with-output-recording-options (stream :record nil)
1834 (call-next-method)))
1835
1836 (defmethod scroll-horizontal :around ((stream output-recording-stream) dx)
1837 (declare (ignore dx))
1838 (with-output-recording-options (stream :record nil)
1839 (call-next-method)))
1840
1841 (defmethod handle-repaint ((stream output-recording-stream) region)
1842 (stream-replay stream region))
1843

  ViewVC Help
Powered by ViewVC 1.1.5