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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.49 - (show annotations)
Sun Jun 16 06:52:08 2002 UTC (11 years, 10 months ago) by adejneka
Branch: MAIN
Changes since 1.48: +83 -70 lines
* WITH-NEW-OUTPUT-RECORD, WITH-OUTPUT-TO-OUTPUT-RECORD: RECORD
  argument is evaluated.

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

  ViewVC Help
Powered by ViewVC 1.1.5