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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.133 - (show annotations)
Sun Jul 15 12:38:37 2007 UTC (6 years, 9 months ago) by dlichteblau
Branch: MAIN
Changes since 1.132: +11 -1 lines
Fixed bug reported by Fred Gilham, [mcclim-devel] Tooltip stuff

	* recording.lisp (erase-output-record): Lock the bounding
        rectangle to the pixel grid and add extra safety at the borders
        to avoid leaving fragments on the border.
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 ;;; (c) copyright 2003 by Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
11
12 ;;; This library is free software; you can redistribute it and/or
13 ;;; modify it under the terms of the GNU Library General Public
14 ;;; License as published by the Free Software Foundation; either
15 ;;; version 2 of the License, or (at your option) any later version.
16 ;;;
17 ;;; This library is distributed in the hope that it will be useful,
18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
20 ;;; Library General Public License for more details.
21 ;;;
22 ;;; You should have received a copy of the GNU Library General Public
23 ;;; License along with this library; if not, write to the
24 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25 ;;; Boston, MA 02111-1307 USA.
26
27 ;;; TODO:
28 ;;;
29 ;;; - Scrolling does not work correctly. Region is given in "window"
30 ;;; coordinates, without bounding-rectangle-position transformation.
31 ;;; (Is it still valid?)
32 ;;;
33 ;;; - Redo setf*-output-record-position, extent recomputation for
34 ;;; compound records
35 ;;;
36 ;;; - When DRAWING-P is NIL, should stream cursor move?
37 ;;;
38 ;;; - :{X,Y}-OFFSET.
39 ;;;
40 ;;; - (SETF OUTPUT-RECORD-START-CURSOR-POSITION) does not affect the
41 ;;; bounding rectangle. What does it affect?
42 ;;;
43 ;;; - How should (SETF OUTPUT-RECORD-POSITION) affect the bounding
44 ;;; rectangle of the parent? Now its bounding rectangle is accurately
45 ;;; recomputed, but it is very inefficient for table formatting. It
46 ;;; seems that CLIM is supposed to keep a "large enougn" rectangle and
47 ;;; to shrink it to the correct size only when the layout is complete
48 ;;; by calling TREE-RECOMPUTE-EXTENT.
49 ;;;
50 ;;; - Computation of the bounding rectangle of lines/polygons ignores
51 ;;; LINE-STYLE-CAP-SHAPE.
52 ;;;
53 ;;; - Rounding of coordinates.
54 ;;;
55 ;;; - Document carefully the interface of
56 ;;; STANDARD-OUTPUT-RECORDING-STREAM.
57 ;;;
58 ;;; - COORD-SEQ is a sequence, not a list.
59
60 ;;; Troubles
61
62 ;;; DC
63 ;;;
64 ;;; Some GFs are defined to have "a default method on CLIM's standard
65 ;;; output record class". What does it mean? What is "CLIM's standard
66 ;;; output record class"? Is it OUTPUT-RECORD or BASIC-OUTPUT-RECORD?
67 ;;; Now they are defined on OUTPUT-RECORD.
68
69
70 (in-package :clim-internals)
71
72 ;;; 16.2.1. The Basic Output Record Protocol
73 #+:cmu(declaim (ftype (function (output-record) (values rational rational))
74 output-record-position))
75 ;; XXX What does #+:CMU mean? FTYPE was excluded from ANSI CL? Other
76 ;; compilers try to check type declarations?
77 (defgeneric output-record-position (record)
78 (:documentation
79 "Returns the x and y position of RECORD. The position is the
80 position of the upper-left corner of its bounding rectangle. The
81 position is relative to the stream, where (0,0) is (initially) the
82 upper-left corner of the stream."))
83
84 (defgeneric* (setf output-record-position) (x y record)
85 (:documentation
86 "Changes the x and y position of the RECORD to be X and Y, and
87 updates the bounding rectangle to reflect the new position (and saved
88 cursor positions, if the output record stores it). If RECORD has any
89 children, all of the children (and their descendants as well) will be
90 moved by the same amount as RECORD was moved. The bounding rectangles
91 of all of RECORD's ancestors will also be updated to be large enough
92 to contain RECORD."))
93
94 #+:cmu(declaim (ftype (function (output-record) (values integer integer))
95 output-record-start-cursor-position))
96 (defgeneric output-record-start-cursor-position (record)
97 (:documentation
98 "Returns the x and y starting cursor position of RECORD. The
99 positions are relative to the stream, where (0,0) is (initially) the
100 upper-left corner of the stream."))
101
102 (defgeneric* (setf output-record-start-cursor-position) (x y record))
103
104 #+:cmu(declaim (ftype (function (output-record) (values integer integer))
105 output-record-end-cursor-position))
106 (defgeneric output-record-end-cursor-position (record)
107 (:documentation
108 "Returns the x and y ending cursor position of RECORD. The
109 positions are relative to the stream, where (0,0) is (initially) the
110 upper-left corner of the stream."))
111
112 (defgeneric* (setf output-record-end-cursor-position) (x y record))
113
114 (defgeneric output-record-parent (record)
115 (:documentation
116 "Returns the output record that is the parent of RECORD, or NIL if
117 RECORD has no parent."))
118
119 (defgeneric (setf output-record-parent) (parent record)
120 (:documentation "Non-standard function."))
121
122 (defgeneric replay-output-record (record stream
123 &optional region x-offset y-offset)
124 (:documentation "Displays the output captured by RECORD on the
125 STREAM, exactly as it was originally captured. The current user
126 transformation, line style, text style, ink and clipping region of
127 STREAM are all ignored. Instead, these are gotten from the output
128 record.
129
130 Only those records that overlap REGION are displayed."))
131
132 (defgeneric output-record-hit-detection-rectangle* (record))
133
134 (defgeneric output-record-refined-position-test (record x y))
135
136 (defgeneric highlight-output-record (record stream state))
137
138 (defgeneric displayed-output-record-ink (displayed-output-record))
139
140 ;;; 16.2.2. Output Record "Database" Protocol
141
142 (defgeneric output-record-children (record))
143
144 (defgeneric add-output-record (child record))
145
146 (defgeneric delete-output-record (child record &optional errorp))
147
148 (defgeneric clear-output-record (record))
149
150 (defgeneric output-record-count (record))
151
152 (defgeneric map-over-output-records-containing-position
153 (function record x y &optional x-offset y-offset &rest function-args)
154 (:documentation "Maps over all of the children of RECORD that
155 contain the point at (X,Y), calling FUNCTION on each one. FUNCTION is
156 a function of one or more arguments, the first argument being the
157 record containing the point. FUNCTION is also called with all of
158 FUNCTION-ARGS as APPLY arguments.
159
160 If there are multiple records that contain the point,
161 MAP-OVER-OUTPUT-RECORDS-CONTAINING-POSITION hits the most recently
162 inserted record first and the least recently inserted record
163 last. Otherwise, the order in which the records are traversed is
164 unspecified."))
165
166 (defgeneric map-over-output-records-overlapping-region
167 (function record region &optional x-offset y-offset &rest function-args)
168 (:documentation "Maps over all of the children of the RECORD that
169 overlap the REGION, calling FUNCTION on each one. FUNCTION is a
170 function of one or more arguments, the first argument being the record
171 overlapping the region. FUNCTION is also called with all of
172 FUNCTION-ARGS as APPLY arguments.
173
174 If there are multiple records that overlap the region and that overlap
175 each other, MAP-OVER-OUTPUT-RECORDS-OVERLAPPING-REGION hits the least
176 recently inserted record first and the most recently inserted record
177 last. Otherwise, the order in which the records are traversed is
178 unspecified. "))
179
180 ;;; From the Franz CLIM user's guide but not in the spec... clearly necessary.
181
182 (defgeneric map-over-output-records-1
183 (continuation record continuation-args))
184
185 (defun map-over-output-records
186 (continuation record &optional x-offset y-offset &rest continuation-args)
187 (declare (ignore x-offset y-offset))
188 (map-over-output-records-1 continuation record continuation-args))
189
190 ;;; 16.2.3. Output Record Change Notification Protocol
191
192 (defgeneric recompute-extent-for-new-child (record child))
193
194 (defgeneric recompute-extent-for-changed-child
195 (record child old-min-x old-min-y old-max-x old-max-y))
196
197 (defgeneric tree-recompute-extent (record))
198
199 ;;; 21.3 Incremental Redisplay Protocol. These generic functions need
200 ;;; to be implemented for all the basic displayed-output-records, so they are
201 ;;; defined in this file.
202 ;;;
203 ;;; match-output-records and find-child-output-record, as defined in
204 ;;; the CLIM spec, are pretty silly. How does incremental redisplay know
205 ;;; what keyword arguments to supply to find-child-output-record? Through
206 ;;; a gf specialized on the type of the record it needs to match... why
207 ;;; not define the search function and the predicate on two records then!
208 ;;;
209 ;;; We'll implement match-output-records and find-child-output-record,
210 ;;; but we won't actually use them. Instead, output-record-equal will
211 ;;; match two records, and find-child-record-equal will search for the
212 ;;; equivalent record.
213
214 (defgeneric match-output-records (record &rest args))
215
216 ;;; These gf's use :most-specific-last because one of the least
217 ;;; specific methods will check the bounding boxes of the records, which
218 ;;; should cause an early out most of the time.
219
220 (defgeneric match-output-records-1 (record &key)
221 (:method-combination and :most-specific-last))
222
223 (defgeneric output-record-equal (record1 record2)
224 (:method-combination and :most-specific-last))
225
226 (defmethod output-record-equal :around (record1 record2)
227 (cond ((eq record1 record2)
228 ;; Some unusual record -- like a Goatee screen line -- might
229 ;; exist in two trees at once
230 t)
231 ((eq (class-of record1) (class-of record2))
232 (let ((result (call-next-method)))
233 (if (eq result 'maybe)
234 nil
235 result)))
236 (t nil)))
237
238 ;;; A fallback method so that something's always applicable.
239
240 (defmethod output-record-equal and (record1 record2)
241 (declare (ignore record1 record2))
242 'maybe)
243
244 ;;; The code for match-output-records-1 and output-record-equal
245 ;;; methods are very similar, hence this macro. In order to exploit
246 ;;; the similarities, it's necessary to treat the slots of the second
247 ;;; record like variables, so for convenience the macro will use
248 ;;; slot-value on both records.
249
250 (defmacro defrecord-predicate (record-type slots &body body)
251 "Each element of SLOTS is either a symbol or (:initarg-name slot-name)."
252 (let* ((slot-names (mapcar #'(lambda (slot-spec)
253 (if (consp slot-spec)
254 (cadr slot-spec)
255 slot-spec))
256 slots))
257 (supplied-vars (mapcar #'(lambda (slot)
258 (gensym (symbol-name
259 (symbol-concat slot '#:-p))))
260 slot-names))
261 (key-args (mapcar #'(lambda (slot-spec supplied)
262 `(,slot-spec nil ,supplied))
263 slots supplied-vars))
264 (key-arg-alist (mapcar #'cons slot-names supplied-vars)))
265 `(progn
266 (defmethod output-record-equal and ((record ,record-type)
267 (record2 ,record-type))
268 (macrolet ((if-supplied ((var &optional (type t)) &body supplied-body)
269 (declare (ignore var type))
270 `(progn ,@supplied-body)))
271 (with-slots ,slot-names
272 record2
273 ,@body)))
274 (defmethod match-output-records-1 and ((record ,record-type)
275 &key ,@key-args)
276 (macrolet ((if-supplied ((var &optional (type t)) &body supplied-body)
277 (let ((supplied-var (cdr (assoc var ',key-arg-alist))))
278 (unless supplied-var
279 (error "Unknown slot ~S" var))
280 `(or (null ,supplied-var)
281 ,@(if (eq type t)
282 `((progn ,@supplied-body))
283 `((if (typep ,var ',type)
284 (progn ,@supplied-body)
285 (error 'type-error
286 :datum ,var
287 :expected-type ',type))))))))
288 ,@body)))
289
290 ))
291 ;;; Macros
292 (defmacro with-output-recording-options ((stream
293 &key (record nil record-supplied-p)
294 (draw nil draw-supplied-p))
295 &body body)
296 (setq stream (stream-designator-symbol stream '*standard-output*))
297 (with-gensyms (continuation)
298 `(flet ((,continuation (,stream)
299 ,(declare-ignorable-form* stream)
300 ,@body))
301 (declare (dynamic-extent #',continuation))
302 (invoke-with-output-recording-options
303 ,stream #',continuation
304 ,(if record-supplied-p record `(stream-recording-p ,stream))
305 ,(if draw-supplied-p draw `(stream-drawing-p ,stream))))))
306
307 ;;; Macro masturbation...
308
309 (defmacro define-invoke-with (macro-name func-name record-type doc-string)
310 `(defmacro ,macro-name ((stream
311 &optional
312 (record-type '',record-type)
313 (record (gensym))
314 &rest initargs)
315 &body body)
316 ,doc-string
317 (setq stream (stream-designator-symbol stream '*standard-output*))
318 (with-gensyms (constructor continuation)
319 (multiple-value-bind (bindings m-i-args)
320 (rebind-arguments initargs)
321 `(let ,bindings
322 (flet ((,constructor ()
323 (make-instance ,record-type ,@m-i-args))
324 (,continuation (,stream ,record)
325 ,(declare-ignorable-form* stream record)
326 ,@body))
327 (declare (dynamic-extent #'constructor #'continuation))
328 (,',func-name ,stream #',continuation ,record-type #',constructor
329 ,@m-i-args)))))))
330
331 (define-invoke-with with-new-output-record invoke-with-new-output-record
332 standard-sequence-output-record
333 "Creates a new output record of type RECORD-TYPE and then captures
334 the output of BODY into the new output record, and inserts the new
335 record into the current \"open\" output record assotiated with STREAM.
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
344 (define-invoke-with with-output-to-output-record
345 invoke-with-output-to-output-record
346 standard-sequence-output-record
347 "Creates a new output record of type RECORD-TYPE and then captures
348 the output of BODY into the new output record. The cursor position of
349 STREAM is initially bound to (0,0)
350 If RECORD is supplied, it is the name of a variable that will be
351 lexically bound to the new output record inside the body. INITARGS are
352 CLOS initargs that are passed to MAKE-INSTANCE when the new output
353 record is created.
354 It returns the created output record.
355 The STREAM argument is a symbol that is bound to an output
356 recording stream. If it is T, *STANDARD-OUTPUT* is used.")
357
358
359 ;;;; Implementation
360
361 (defclass basic-output-record (standard-bounding-rectangle output-record)
362 ((parent :initarg :parent ; XXX
363 :initform nil
364 :accessor output-record-parent)) ; XXX
365 (:documentation "Implementation class for the Basic Output Record Protocol."))
366
367 (defmethod initialize-instance :after ((record basic-output-record)
368 &key (x-position 0.0d0)
369 (y-position 0.0d0))
370 (setf (rectangle-edges* record)
371 (values x-position y-position x-position y-position)))
372
373 ;;; XXX I'd really like to get rid of the x and y slots. They are surely
374 ;;; redundant with the bounding rectangle coordinates.
375 (defclass compound-output-record (basic-output-record)
376 ((x :initarg :x-position
377 :initform 0.0d0
378 :documentation "X-position of the empty record.")
379 (y :initarg :y-position
380 :initform 0.0d0
381 :documentation "Y-position of the empty record.")
382 (in-moving-p :initform nil
383 :documentation "Is set while changing the position."))
384 (:documentation "Implementation class for output records with children."))
385
386 ;;; 16.2.1. The Basic Output Record Protocol
387 (defmethod output-record-position ((record basic-output-record))
388 (bounding-rectangle-position record))
389
390 (defmethod* (setf output-record-position) (nx ny (record basic-output-record))
391 (with-standard-rectangle (x1 y1 x2 y2)
392 record
393 (let ((dx (- nx x1))
394 (dy (- ny y1)))
395 (setf (rectangle-edges* record)
396 (values nx ny (+ x2 dx) (+ y2 dy)))))
397 (values nx ny))
398
399 (defmethod* (setf output-record-position) :around
400 (nx ny (record basic-output-record))
401 (with-bounding-rectangle* (min-x min-y max-x max-y) record
402 (call-next-method)
403 (let ((parent (output-record-parent record)))
404 (when (and parent (not (slot-value parent 'in-moving-p)))
405 (recompute-extent-for-changed-child parent record
406 min-x min-y max-x max-y))))
407 (values nx ny))
408
409 (defmethod* (setf output-record-position)
410 :before (nx ny (record compound-output-record))
411 (with-standard-rectangle* (:x1 x1 :y1 y1)
412 record
413 (letf (((slot-value record 'in-moving-p) t))
414 (let ((dx (- nx x1))
415 (dy (- ny y1)))
416 (map-over-output-records
417 (lambda (child)
418 (multiple-value-bind (x y) (output-record-position child)
419 (setf (output-record-position child)
420 (values (+ x dx) (+ y dy)))))
421 record)))))
422
423 (defmethod output-record-start-cursor-position ((record basic-output-record))
424 (values nil nil))
425
426 (defmethod* (setf output-record-start-cursor-position)
427 (x y (record basic-output-record))
428 (values x y))
429
430 (defmethod output-record-end-cursor-position ((record basic-output-record))
431 (values nil nil))
432
433 (defmethod* (setf output-record-end-cursor-position)
434 (x y (record basic-output-record))
435 (values x y))
436
437 #+cmu
438 (progn
439 ;; Sometimes CMU's PCL fails with forward reference classes, so this
440 ;; is a kludge to keep it happy.
441 ;;
442 ;; This was reported as a bug to cmucl-imp [<E18vKN1-0004DQ-00@saphir.local>]
443 ;;
444 ;; In short it exposes itself when you compile and load into a
445 ;; _virgin_ lisp the following:
446 ;;
447 ;; (defclass foo (bar) ())
448 ;; (defun barz () (make-instance 'foo))
449 ;; (defclass bar () ())
450 ;;
451 ;; --GB 2003-03-18
452 ;;
453 (defclass gs-ink-mixin () ())
454 (defclass gs-clip-mixin () ())
455 (defclass gs-line-style-mixin () ())
456 (defclass gs-text-style-mixin () ()))
457
458 ;;; Humph. It'd be nice to tie this to the actual definition of a
459 ;;; medium. -- moore
460 (defclass complete-medium-state
461 (gs-ink-mixin gs-clip-mixin gs-line-style-mixin gs-text-style-mixin)
462 ())
463
464 (defun replay (record stream &optional region)
465 (if (typep stream 'encapsulating-stream)
466 (replay record (encapsulating-stream-stream stream) region)
467 (progn
468 (stream-close-text-output-record stream)
469 (when (stream-drawing-p stream)
470 (with-cursor-off stream ;;FIXME?
471 (letf (((stream-cursor-position stream) (values 0 0))
472 ((stream-recording-p stream) nil)
473 ;; Is there a better value to bind to baseline?
474 ((slot-value stream 'baseline) (slot-value stream 'baseline)))
475 (with-sheet-medium (medium stream)
476 (let ((transformation (medium-transformation medium)))
477 (unwind-protect
478 (progn
479 (setf (medium-transformation medium)
480 +identity-transformation+)
481 (replay-output-record record stream region))
482 (setf (medium-transformation medium) transformation))))))))))
483
484 (defmethod replay-output-record ((record compound-output-record) stream
485 &optional region (x-offset 0) (y-offset 0))
486 (when (null region)
487 (setq region (or (pane-viewport-region stream) +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 (defun highlight-output-record-rectangle (record stream state)
503 (with-identity-transformation (stream)
504 (multiple-value-bind (x1 y1 x2 y2)
505 (output-record-hit-detection-rectangle* record)
506 (ecase state
507 (:highlight
508 (draw-rectangle* (sheet-medium stream) x1 y1 (1- x2) (1- y2)
509 :filled nil :ink +foreground-ink+)) ; XXX +FLIPPING-INK+?
510 (:unhighlight
511 ;; FIXME: repaint the hit detection rectangle. It could be bigger than
512 ;; the bounding rectangle.
513 (repaint-sheet stream record)
514
515 ;; Using queue-repaint should be faster in apps (such as clouseau) that
516 ;; highlight/unhighlight many bounding rectangles at once. The event
517 ;; code should merge these into a single larger repaint. Unfortunately,
518 ;; since an enqueued repaint does not occur immediately, and highlight
519 ;; rectangles are not recorded, newer highlighting gets wiped out
520 ;; shortly after being drawn. So, we aren't ready for this yet.
521 #+NIL
522 (queue-repaint stream (make-instance 'window-repaint-event
523 :sheet stream
524 :region (transform-region
525 (sheet-native-transformation stream)
526 record))))))))
527
528 ;;; XXX Should this only be defined on recording streams?
529 (defmethod highlight-output-record ((record output-record) stream state)
530 ;; XXX DC
531 ;; XXX Disable recording?
532 (highlight-output-record-rectangle record stream state))
533
534 ;;; 16.2.2. The Output Record "Database" Protocol
535
536 ;; These two aren't in the spec, but are needed to make indirect adding/deleting
537 ;; of GADGET-OUTPUT-RECORDs work:
538
539 (defgeneric note-output-record-lost-sheet (record sheet))
540 (defgeneric note-output-record-got-sheet (record sheet))
541
542 (defmethod note-output-record-lost-sheet ((record output-record) sheet)
543 (declare (ignore record sheet))
544 (values))
545
546 (defmethod note-output-record-lost-sheet :after ((record compound-output-record) sheet)
547 (map-over-output-records #'note-output-record-lost-sheet record 0 0 sheet))
548
549 (defmethod note-output-record-got-sheet ((record output-record) sheet)
550 (declare (ignore record sheet))
551 (values))
552
553 (defmethod note-output-record-got-sheet :after ((record compound-output-record) sheet)
554 (map-over-output-records #'note-output-record-got-sheet record 0 0 sheet))
555
556 (defun find-output-record-sheet (record)
557 "Walks up the parents of RECORD, searching for an output history from which
558 the associated sheet can be determined."
559 (typecase record
560 (stream-output-history-mixin (output-history-stream record))
561 (basic-output-record (find-output-record-sheet (output-record-parent record)))))
562
563 (defmethod output-record-children ((record basic-output-record))
564 nil)
565
566 (defmethod add-output-record (child (record basic-output-record))
567 (declare (ignore child))
568 (error "Cannot add a child to ~S." record))
569
570 (defmethod add-output-record :before (child (record compound-output-record))
571 (let ((parent (output-record-parent child)))
572 (cond (parent
573 (restart-case
574 (error "~S already has a parent ~S." child parent)
575 (delete ()
576 :report "Delete from the old parent."
577 (delete-output-record child parent))))
578 ((eq record child)
579 (error "~S is being added to itself" record))
580 ((eq (output-record-parent record) child)
581 (error "child ~S is being added to its own child ~S"
582 child record)))))
583
584 (defmethod add-output-record :after (child (record compound-output-record))
585 (recompute-extent-for-new-child record child)
586 (when (eq record (output-record-parent child))
587 (let ((sheet (find-output-record-sheet record)))
588 (when sheet (note-output-record-got-sheet child sheet)))))
589
590 (defmethod delete-output-record :before (child (record basic-output-record)
591 &optional (errorp t))
592 (declare (ignore errorp))
593 (let ((sheet (find-output-record-sheet record)))
594 (when sheet
595 (note-output-record-lost-sheet child sheet))))
596
597 (defmethod delete-output-record (child (record basic-output-record)
598 &optional (errorp t))
599 (declare (ignore child))
600 (when errorp (error "Cannot delete a child from ~S." record)))
601
602 (defmethod delete-output-record :after (child (record compound-output-record)
603 &optional (errorp t))
604 (declare (ignore errorp))
605 (with-bounding-rectangle* (x1 y1 x2 y2) child
606 (recompute-extent-for-changed-child record child x1 y1 x2 y2)))
607
608 (defmethod clear-output-record ((record basic-output-record))
609 (error "Cannot clear ~S." record))
610
611 (defmethod clear-output-record :before ((record compound-output-record))
612 (let ((sheet (find-output-record-sheet record)))
613 (when sheet
614 (map-over-output-records #'note-output-record-lost-sheet record 0 0 sheet))))
615
616 (defmethod clear-output-record :after ((record compound-output-record))
617 ;; XXX banish x and y
618 (with-slots (x y)
619 record
620 (setf (rectangle-edges* record) (values x y x y))))
621
622 (defmethod output-record-count ((record basic-output-record))
623 0)
624
625 (defmethod map-over-output-records-1
626 (function (record displayed-output-record) function-args)
627 (declare (ignore function function-args))
628 nil)
629
630 ;;; This needs to work in "most recently added last" order. Is this
631 ;;; implementation right? -- APD, 2002-06-13
632 #+nil
633 (defmethod map-over-output-records
634 (function (record compound-output-record)
635 &optional (x-offset 0) (y-offset 0)
636 &rest function-args)
637 (declare (ignore x-offset y-offset))
638 (map nil (lambda (child) (apply function child function-args))
639 (output-record-children record)))
640
641 (defmethod map-over-output-records-containing-position
642 (function (record displayed-output-record) x y
643 &optional (x-offset 0) (y-offset 0)
644 &rest function-args)
645 (declare (ignore function x y x-offset y-offset function-args))
646 nil)
647
648 ;;; This needs to work in "most recently added first" order. Is this
649 ;;; implementation right? -- APD, 2002-06-13
650 #+nil
651 (defmethod map-over-output-records-containing-position
652 (function (record compound-output-record) x y
653 &optional (x-offset 0) (y-offset 0)
654 &rest function-args)
655 (declare (ignore x-offset y-offset))
656 (map nil
657 (lambda (child)
658 (when (and (multiple-value-bind (min-x min-y max-x max-y)
659 (output-record-hit-detection-rectangle* child)
660 (and (<= min-x x max-x) (<= min-y y max-y)))
661 (output-record-refined-position-test child x y))
662 (apply function child function-args)))
663 (output-record-children record)))
664
665 (defmethod map-over-output-records-overlapping-region
666 (function (record displayed-output-record) region
667 &optional (x-offset 0) (y-offset 0)
668 &rest function-args)
669 (declare (ignore function region x-offset y-offset function-args))
670 nil)
671
672 ;;; This needs to work in "most recently added last" order. Is this
673 ;;; implementation right? -- APD, 2002-06-13
674 #+nil
675 (defmethod map-over-output-records-overlapping-region
676 (function (record compound-output-record) region
677 &optional (x-offset 0) (y-offset 0)
678 &rest function-args)
679 (declare (ignore x-offset y-offset))
680 (map nil
681 (lambda (child) (when (region-intersects-region-p region child)
682 (apply function child function-args)))
683 (output-record-children record)))
684
685 ;;; XXX Dunno about this definition... -- moore
686 ;;; Your apprehension is justified, but we lack a better means by which
687 ;;; to distinguish "empty" compound records (roots of trees of compound
688 ;;; records, containing no non-compound records). Such subtrees should
689 ;;; not affect bounding rectangles. -- Hefner
690 (defun null-bounding-rectangle-p (bbox)
691 (with-bounding-rectangle* (x1 y1 x2 y2) bbox
692 (and (= x1 x2)
693 (= y1 y2))))
694
695 ;;; 16.2.3. Output Record Change Notification Protocol
696 (defmethod recompute-extent-for-new-child
697 ((record compound-output-record) child)
698 (unless (null-bounding-rectangle-p child)
699 (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2) record
700 ;; I expect there's a bug here. If you create a record A, add an empty child B
701 ;; then add a displayed-output-record C, the code below will use min/max to
702 ;; grow the all-zero bounds of A, typically giving a bogus x1,y1 of 0,0. --Hefner
703 (if (eql 1 (output-record-count record))
704 (setf (rectangle-edges* record) (bounding-rectangle* child))
705 (with-bounding-rectangle* (x1-child y1-child x2-child y2-child)
706 child
707 (setf (rectangle-edges* record)
708 (values (min old-x1 x1-child) (min old-y1 y1-child)
709 (max old-x2 x2-child) (max old-y2 y2-child)))))
710 (let ((parent (output-record-parent record)))
711 (when parent
712 (recompute-extent-for-changed-child
713 parent record old-x1 old-y1 old-x2 old-y2)))))
714 record)
715
716 (defmethod %tree-recompute-extent* ((record compound-output-record))
717 ;; Internal helper function
718 (let ((new-x1 0)
719 (new-y1 0)
720 (new-x2 0)
721 (new-y2 0)
722 (first-time t))
723 (map-over-output-records
724 (lambda (child)
725 (if first-time
726 (progn
727 (multiple-value-setq (new-x1 new-y1 new-x2 new-y2)
728 (bounding-rectangle* child))
729 (setq first-time nil))
730 (with-bounding-rectangle* (cx1 cy1 cx2 cy2) child
731 (minf new-x1 cx1)
732 (minf new-y1 cy1)
733 (maxf new-x2 cx2)
734 (maxf new-y2 cy2))))
735 record)
736 (if first-time
737 ;; XXX banish x y
738 (with-slots (x y) record
739 (values x y x y))
740 (values new-x1 new-y1 new-x2 new-y2))))
741
742 (defgeneric tree-recompute-extent-aux (record))
743
744 (defmethod tree-recompute-extent-aux (record)
745 (bounding-rectangle* record))
746
747 (defmethod tree-recompute-extent-aux ((record compound-output-record))
748 (let ((new-x1 0)
749 (new-y1 0)
750 (new-x2 0)
751 (new-y2 0)
752 (first-time t))
753 (map-over-output-records
754 (lambda (child)
755 (if first-time
756 (progn
757 (multiple-value-setq (new-x1 new-y1 new-x2 new-y2)
758 (tree-recompute-extent-aux child))
759 (setq first-time nil))
760 (multiple-value-bind (cx1 cy1 cx2 cy2)
761 (tree-recompute-extent-aux child)
762 (minf new-x1 cx1)
763 (minf new-y1 cy1)
764 (maxf new-x2 cx2)
765 (maxf new-y2 cy2))))
766 record)
767 (with-slots (x y)
768 record
769 (if first-time ;No children
770 (bounding-rectangle* record)
771 (progn
772 ;; XXX banish x,y
773 (setf x new-x1 y new-y1)
774 (setf (rectangle-edges* record)
775 (values new-x1 new-y1 new-x2 new-y2)))))))
776
777 (defmethod recompute-extent-for-changed-child
778 ((record compound-output-record) changed-child
779 old-min-x old-min-y old-max-x old-max-y)
780 (with-bounding-rectangle* (ox1 oy1 ox2 oy2) record
781 (with-bounding-rectangle* (cx1 cy1 cx2 cy2) changed-child
782 ;; If record is currently empty, use the child's bbox directly. Else..
783 ;; Does the new rectangle of the child contain the original rectangle?
784 ;; If so, we can use min/max to grow record's current rectangle.
785 ;; If not, the child has shrunk, and we need to fully recompute.
786 (multiple-value-bind (nx1 ny1 nx2 ny2)
787 (cond
788 ;; The child has been deleted; who knows what the
789 ;; new bounding box might be.
790 ((not (output-record-parent changed-child))
791 (%tree-recompute-extent* record))
792 ;; Only one child of record, and we already have the bounds.
793 ((eql (output-record-count record) 1)
794 (values cx1 cy1 cx2 cy2))
795 ;; If our record occupied no space (had no children, or had only
796 ;; children similarly occupying no space, hackishly determined by
797 ;; null-bounding-rectangle-p), recompute the extent now, otherwise
798 ;; the next COND clause would, as an optimization, attempt to extend
799 ;; our current bounding rectangle, which is invalid.
800 ((null-bounding-rectangle-p record)
801 (%tree-recompute-extent* record))
802 ;; In the following cases, we can grow the new bounding rectangle
803 ;; from its previous state:
804 ((or
805 ;; If the child was originally empty, it should not have affected
806 ;; previous computation of our bounding rectangle.
807 ;; This is hackish for reasons similar to the above.
808 (and (zerop old-min-x) (zerop old-min-y)
809 (zerop old-max-x) (zerop old-max-y))
810 ;; For each old child coordinate, either it was not
811 ;; involved in determining the bounding rectangle of the
812 ;; parent, or else it is the same as the corresponding
813 ;; new child coordinate.
814 (and (or (> old-min-x ox1) (= old-min-x cx1))
815 (or (> old-min-y oy1) (= old-min-y cy1))
816 (or (< old-max-x ox2) (= old-max-x cx2))
817 (or (< old-max-y oy2) (= old-max-y cy2)))
818 ;; New child bounds contain old child bounds, so use min/max
819 ;; to extend the already-calculated rectangle.
820 (and (<= cx1 old-min-x) (<= cy1 old-min-y)
821 (>= cx2 old-max-x) (>= cy2 old-max-y)))
822 (values (min cx1 ox1) (min cy1 oy1)
823 (max cx2 ox2) (max cy2 oy2)))
824 ;; No shortcuts - we must compute a new bounding box from those of
825 ;; all our children. We want to avoid this - in worst cases, such as
826 ;; a toplevel output history, large graph, or table, there may exist
827 ;; thousands of children. Without the above optimizations,
828 ;; construction becomes O(N^2) due to bounding rectangle calculation.
829 (t (%tree-recompute-extent* record)))
830 ;; XXX banish x, y
831 (with-slots (x y)
832 record
833 (setf x nx1 y ny1)
834 (setf (rectangle-edges* record) (values nx1 ny1 nx2 ny2))
835 (let ((parent (output-record-parent record)))
836 (unless (or (null parent)
837 (and (= nx1 ox1) (= ny1 oy1)
838 (= nx2 ox2) (= nx2 oy2)))
839 (recompute-extent-for-changed-child parent record
840 ox1 oy1 ox2 oy2)))))))
841 record)
842
843 ;; There was once an :around method on recompute-extent-for-changed-child here,
844 ;; but I've eliminated it. Its function was to notify the parent OR in case
845 ;; the bounding rect here changed - I've merged this into the above method.
846 ;; --Hefner, 8/7/02
847
848 (defmethod tree-recompute-extent ((record compound-output-record))
849 (tree-recompute-extent-aux record)
850 record)
851
852 (defmethod tree-recompute-extent :around ((record compound-output-record))
853 (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2)
854 record
855 (call-next-method)
856 (with-bounding-rectangle* (x1 y1 x2 y2)
857 record
858 (let ((parent (output-record-parent record)))
859 (when (and parent
860 (not (and (= old-x1 x1)
861 (= old-y1 y1)
862 (= old-x2 x2)
863 (= old-y2 y2))))
864 (recompute-extent-for-changed-child parent record
865 old-x1 old-y1
866 old-x2 old-y2)))))
867 record)
868
869 ;;; 16.3.1. Standard output record classes
870
871 (defclass standard-sequence-output-record (compound-output-record)
872 ((children :initform (make-array 8 :adjustable t :fill-pointer 0)
873 :reader output-record-children)))
874
875 (defmethod add-output-record (child (record standard-sequence-output-record))
876 (vector-push-extend child (output-record-children record))
877 (setf (output-record-parent child) record))
878
879 (defmethod delete-output-record (child (record standard-sequence-output-record)
880 &optional (errorp t))
881 (with-slots (children) record
882 (let ((pos (position child children :test #'eq)))
883 (if (null pos)
884 (when errorp
885 (error "~S is not a child of ~S" child record))
886 (progn
887 (setq children (replace children children
888 :start1 pos
889 :start2 (1+ pos)))
890 (decf (fill-pointer children))
891 (setf (output-record-parent child) nil))))))
892
893 (defmethod clear-output-record ((record standard-sequence-output-record))
894 (let ((children (output-record-children record)))
895 (map 'nil (lambda (child) (setf (output-record-parent child) nil))
896 children)
897 (fill children nil)
898 (setf (fill-pointer children) 0)))
899
900 (defmethod output-record-count ((record standard-sequence-output-record))
901 (length (output-record-children record)))
902
903 (defmethod map-over-output-records-1
904 (function (record standard-sequence-output-record) function-args)
905 "Applies FUNCTION to all children in the order they were added."
906 (if function-args
907 (loop with children = (output-record-children record)
908 for child across children
909 do (apply function child function-args))
910 (loop with children = (output-record-children record)
911 for child across children
912 do (funcall function child))))
913
914 (defmethod map-over-output-records-containing-position
915 (function (record standard-sequence-output-record) x y
916 &optional (x-offset 0) (y-offset 0)
917 &rest function-args)
918 "Applies FUNCTION to children, containing (X,Y), in the reversed
919 order they were added."
920 (declare (ignore x-offset y-offset))
921 (loop with children = (output-record-children record)
922 for i from (1- (length children)) downto 0
923 for child = (aref children i)
924 when (and (multiple-value-bind (min-x min-y max-x max-y)
925 (output-record-hit-detection-rectangle* child)
926 (and (<= min-x x max-x) (<= min-y y max-y)))
927 (output-record-refined-position-test child x y))
928 do (apply function child function-args)))
929
930 (defmethod map-over-output-records-overlapping-region
931 (function (record standard-sequence-output-record) region
932 &optional (x-offset 0) (y-offset 0)
933 &rest function-args)
934 "Applies FUNCTION to children, overlapping REGION, in the order they
935 were added."
936 (declare (ignore x-offset y-offset))
937 (loop with children = (output-record-children record)
938 for child across children
939 when (region-intersects-region-p region child)
940 do (apply function child function-args)))
941
942
943 ;;; tree output recording
944
945 (defclass tree-output-record-entry ()
946 ((record :initarg :record :reader tree-output-record-entry-record)
947 (cached-rectangle :initform nil :accessor tree-output-record-entry-cached-rectangle)
948 (inserted-nr :initarg :inserted-nr :accessor tree-output-record-entry-inserted-nr)))
949
950 (defun make-tree-output-record-entry (record inserted-nr)
951 (make-instance 'tree-output-record-entry :record record :inserted-nr inserted-nr))
952
953 (defun %record-to-spatial-tree-rectangle (r)
954 (rectangles:make-rectangle
955 :lows `(,(bounding-rectangle-min-x r)
956 ,(bounding-rectangle-min-y r))
957 :highs `(,(bounding-rectangle-max-x r)
958 ,(bounding-rectangle-max-y r))))
959
960 (defun %output-record-entry-to-spatial-tree-rectangle (r)
961 (when (null (tree-output-record-entry-cached-rectangle r))
962 (let* ((record (tree-output-record-entry-record r)))
963 (setf (tree-output-record-entry-cached-rectangle r) (%record-to-spatial-tree-rectangle record))))
964 (tree-output-record-entry-cached-rectangle r))
965
966 (defun %make-tree-output-record-tree ()
967 (spatial-trees:make-spatial-tree :r
968 :rectfun #'%output-record-entry-to-spatial-tree-rectangle))
969
970 (defclass standard-tree-output-record (compound-output-record)
971 ((children :initform (%make-tree-output-record-tree)
972 :accessor %tree-record-children)
973 (children-hash :initform (make-hash-table :test #'eql) :reader %tree-record-children-cache)
974 (last-insertion-nr :initform 0 :accessor last-insertion-nr)))
975
976 (defun %entry-in-children-cache (record entry)
977 (gethash entry (%tree-record-children-cache record)))
978
979 (defun (setf %entry-in-children-cache) (new-val record entry)
980 (setf (gethash entry (%tree-record-children-cache record)) new-val))
981
982 (defun %remove-entry-from-children-cache (record entry)
983 (remhash entry (%tree-record-children-cache record)))
984
985 (defmethod output-record-children ((record standard-tree-output-record))
986 (map 'list
987 #'tree-output-record-entry-record
988 (spatial-trees:search (%record-to-spatial-tree-rectangle record)
989 (%tree-record-children record))))
990
991 (defmethod add-output-record (child (record standard-tree-output-record))
992 (let ((entry (make-tree-output-record-entry child (incf (last-insertion-nr record)))))
993 (spatial-trees:insert entry (%tree-record-children record))
994 (setf (output-record-parent child) record)
995 (setf (%entry-in-children-cache record child) entry)))
996
997 (defmethod delete-output-record (child (record standard-tree-output-record) &optional (errorp t))
998 (let ((entry (find child (spatial-trees:search (%entry-in-children-cache record child)
999 (%tree-record-children record))
1000 :key #'tree-output-record-entry-record)))
1001 (cond
1002 ((not (null entry))
1003 (spatial-trees:delete entry (%tree-record-children record))
1004 (%remove-entry-from-children-cache record child)
1005 (setf (output-record-parent child) nil))
1006 (errorp (error "~S is not a child of ~S" child record)))))
1007
1008 (defmethod clear-output-record ((record standard-tree-output-record))
1009 (dolist (child (output-record-children record))
1010 (setf (output-record-parent child) nil)
1011 (%remove-entry-from-children-cache record child))
1012 (setf (%tree-record-children record) (%make-tree-output-record-tree)))
1013
1014 (defun map-over-tree-output-records (function record rectangle sort-order function-args)
1015 (dolist (child (sort (spatial-trees:search rectangle
1016 (%tree-record-children record))
1017 (ecase sort-order
1018 (:most-recent-first #'>)
1019 (:most-recent-last #'<))
1020 :key #'tree-output-record-entry-inserted-nr))
1021 (apply function (tree-output-record-entry-record child) function-args)))
1022
1023 (defmethod map-over-output-records-1 (function (record standard-tree-output-record) function-args)
1024 (map-over-tree-output-records function record (%record-to-spatial-tree-rectangle record) :most-recent-last
1025 function-args))
1026
1027 (defmethod map-over-output-records-containing-position (function (record standard-tree-output-record) x y &optional x-offset y-offset &rest function-args)
1028 (declare (ignore x-offset y-offset))
1029 (map-over-tree-output-records function record (rectangles:make-rectangle :lows `(,x ,y) :highs `(,x ,y)) :most-recent-first
1030 function-args))
1031
1032 (defmethod map-over-output-records-overlapping-region (function (record standard-tree-output-record) region &optional x-offset y-offset &rest function-args)
1033 (declare (ignore x-offset y-offset))
1034 (typecase region
1035 (everywhere-region (map-over-output-records-1 function record function-args))
1036 (nowhere-region nil)
1037 (otherwise (map-over-tree-output-records
1038 (lambda (child)
1039 (if (region-intersects-region-p (multiple-value-call 'make-rectangle* (bounding-rectangle* child))
1040 region)
1041 (apply function child function-args)))
1042 record (%record-to-spatial-tree-rectangle (bounding-rectangle region)) :most-recent-last
1043 nil))))
1044
1045 (defmethod recompute-extent-for-changed-child :around ((record standard-tree-output-record) child old-min-x old-min-y old-max-x old-max-y)
1046 (when (eql record (output-record-parent child))
1047 (let ((entry (%entry-in-children-cache record child)))
1048 (spatial-trees:delete entry (%tree-record-children record))
1049 (setf (tree-output-record-entry-cached-rectangle entry) nil)
1050 (spatial-trees:insert entry (%tree-record-children record))))
1051 (call-next-method))
1052
1053 ;;;
1054
1055 (defmethod match-output-records ((record t) &rest args)
1056 (apply #'match-output-records-1 record args))
1057
1058 ;;; Factor out the graphics state portions of the output records so
1059 ;;; they can be manipulated seperately e.g., by incremental
1060 ;;; display. The individual slots of a graphics state are factored into mixin
1061 ;;; classes so that each output record can capture only the state that it needs.
1062 ;;; -- moore
1063
1064 ;;; It would be appealing to define a setf method, e.g. (setf
1065 ;;; medium-graphics-state), for setting a medium's state from a graphics state
1066 ;;; object, but that would require us to define a medium-graphics-state reader
1067 ;;; that would cons a state object. I don't want to do that.
1068
1069 (defclass graphics-state ()
1070 ()
1071 (:documentation "Stores those parts of the medium/stream graphics state
1072 that need to be restored when drawing an output record"))
1073
1074 (defclass gs-ink-mixin (graphics-state)
1075 ((ink :initarg :ink :accessor graphics-state-ink)))
1076
1077 (defmethod initialize-instance :after ((obj gs-ink-mixin)
1078 &key (stream nil)
1079 (medium (when stream
1080 (sheet-medium stream))))
1081 (when (and medium (not (slot-boundp obj 'ink)))
1082 (setf (slot-value obj 'ink) (medium-ink medium))))
1083
1084 (defmethod replay-output-record :around
1085 ((record gs-ink-mixin) stream &optional region x-offset y-offset)
1086 (with-drawing-options (stream :ink (graphics-state-ink record))
1087 (call-next-method)))
1088
1089 (defrecord-predicate gs-ink-mixin (ink)
1090 (if-supplied (ink)
1091 (design-equalp (slot-value record 'ink) ink)))
1092
1093 (defclass gs-clip-mixin (graphics-state)
1094 ((clip :initarg :clipping-region :accessor graphics-state-clip
1095 :documentation "Clipping region in stream coordinates.")))
1096
1097 (defmethod initialize-instance :after ((obj gs-clip-mixin)
1098 &key (stream nil)
1099 (medium (when stream
1100 (sheet-medium stream))))
1101 (when medium
1102 (with-slots (clip)
1103 obj
1104 (let ((clip-region (if (slot-boundp obj 'clip)
1105 (region-intersection (medium-clipping-region
1106 medium)
1107 clip)
1108 (medium-clipping-region medium))))
1109 (setq clip (transform-region (medium-transformation medium)
1110 clip-region))))))
1111
1112 (defmethod replay-output-record :around
1113 ((record gs-clip-mixin) stream &optional region x-offset y-offset)
1114 (with-drawing-options (stream :clipping-region (graphics-state-clip record))
1115 (call-next-method)))
1116
1117 (defrecord-predicate gs-clip-mixin ((:clipping-region clip))
1118 (if-supplied (clip)
1119 (region-equal (slot-value record 'clip) clip)))
1120
1121 ;;; 16.3.2. Graphics Displayed Output Records
1122 (defclass standard-displayed-output-record (gs-clip-mixin gs-ink-mixin
1123 basic-output-record
1124 displayed-output-record)
1125 ((ink :reader displayed-output-record-ink)
1126 (stream :initarg :stream))
1127 (:documentation "Implementation class for DISPLAYED-OUTPUT-RECORD.")
1128 (:default-initargs :stream nil))
1129
1130 (defclass gs-line-style-mixin (graphics-state)
1131 ((line-style :initarg :line-style :accessor graphics-state-line-style)))
1132
1133 (defmethod initialize-instance :after ((obj gs-line-style-mixin)
1134 &key (stream nil)
1135 (medium (when stream
1136 (sheet-medium stream))))
1137 (when medium
1138 (unless (slot-boundp obj 'line-style)
1139 (setf (slot-value obj 'line-style) (medium-line-style medium)))))
1140
1141 (defmethod replay-output-record :around
1142 ((record gs-line-style-mixin) stream &optional region x-offset y-offset)
1143 (with-drawing-options (stream :line-style (graphics-state-line-style record))
1144 (call-next-method)))
1145
1146 (defrecord-predicate gs-line-style-mixin (line-style)
1147 (if-supplied (line-style)
1148 (line-style-equalp (slot-value record 'line-style) line-style)))
1149
1150 (defgeneric graphics-state-line-style-border (record medium)
1151 (:method ((record gs-line-style-mixin) medium)
1152 (/ (line-style-effective-thickness (graphics-state-line-style record)
1153 medium)
1154 2)))
1155
1156 (defclass gs-text-style-mixin (graphics-state)
1157 ((text-style :initarg :text-style :accessor graphics-state-text-style)))
1158
1159 (defmethod initialize-instance :after ((obj gs-text-style-mixin)
1160 &key (stream nil)
1161 (medium (when stream
1162 (sheet-medium stream))))
1163 (when medium
1164 (unless (slot-boundp obj 'text-style)
1165 (setf (slot-value obj 'text-style) (medium-text-style medium)))))
1166
1167 (defmethod replay-output-record :around
1168 ((record gs-text-style-mixin) stream &optional region x-offset y-offset)
1169 (with-drawing-options (stream :text-style (graphics-state-text-style record))
1170 (call-next-method)))
1171
1172 (defrecord-predicate gs-text-style-mixin (text-style)
1173 (if-supplied (text-style)
1174 (text-style-equalp (slot-value record 'text-style) text-style)))
1175
1176 (defclass standard-graphics-displayed-output-record
1177 (standard-displayed-output-record
1178 graphics-displayed-output-record)
1179 ())
1180
1181 (defmethod match-output-records-1 and
1182 ((record standard-displayed-output-record)
1183 &key (x1 nil x1-p) (y1 nil y1-p)
1184 (x2 nil x2-p) (y2 nil y2-p)
1185 (bounding-rectangle nil bounding-rectangle-p))
1186 (if bounding-rectangle-p
1187 (region-equal record bounding-rectangle)
1188 (multiple-value-bind (my-x1 my-y1 my-x2 my-y2)
1189 (bounding-rectangle* record)
1190 (macrolet ((coordinate=-or-lose (key mine)
1191 `(if (typep ,key 'coordinate)
1192 (coordinate= ,mine ,key)
1193 (error 'type-error
1194 :datum ,key
1195 :expected-type 'coordinate))))
1196 (and (or (null x1-p)
1197 (coordinate=-or-lose x1 my-x1))
1198 (or (null y1-p)
1199 (coordinate=-or-lose y1 my-y1))
1200 (or (null x2-p)
1201 (coordinate=-or-lose x2 my-x2))
1202 (or (null y2-p)
1203 (coordinate=-or-lose y2 my-y2)))))))
1204
1205 (defmethod output-record-equal and ((record standard-displayed-output-record)
1206 (record2 standard-displayed-output-record))
1207 (region-equal record record2))
1208
1209 (defclass coord-seq-mixin ()
1210 ((coord-seq :accessor coord-seq :initarg :coord-seq))
1211 (:documentation "Mixin class that implements methods for records that contain
1212 sequences of coordinates."))
1213
1214 (defun coord-seq-bounds (coord-seq border)
1215 (setf border (ceiling border))
1216 (let* ((min-x (elt coord-seq 0))
1217 (min-y (elt coord-seq 1))
1218 (max-x min-x)
1219 (max-y min-y))
1220 (do-sequence ((x y) coord-seq)
1221 (minf min-x x)
1222 (minf min-y y)
1223 (maxf max-x x)
1224 (maxf max-y y))
1225 (values (floor (- min-x border))
1226 (floor (- min-y border))
1227 (ceiling (+ max-x border))
1228 (ceiling (+ max-y border)))))
1229
1230 ;;; record must be a standard-rectangle
1231
1232 (defmethod* (setf output-record-position) :around
1233 (nx ny (record coord-seq-mixin))
1234 (with-standard-rectangle* (:x1 x1 :y1 y1)
1235 record
1236 (let ((dx (- nx x1))
1237 (dy (- ny y1))
1238 (coords (slot-value record 'coord-seq)))
1239 (multiple-value-prog1
1240 (call-next-method)
1241 (loop for i from 0 below (length coords) by 2
1242 do (progn
1243 (incf (aref coords i) dx)
1244 (incf (aref coords (1+ i)) dy)))))))
1245
1246 (defmethod match-output-records-1 and ((record coord-seq-mixin)
1247 &key (coord-seq nil coord-seq-p))
1248 (or (null coord-seq-p)
1249 (let* ((my-coord-seq (slot-value record 'coord-seq))
1250 (len (length my-coord-seq)))
1251 (and (eql len (length coord-seq))
1252 (loop for elt1 across my-coord-seq
1253 for elt2 across coord-seq
1254 always (coordinate= elt1 elt2))))))
1255
1256 (defmacro generate-medium-recording-body (class-name method-name args)
1257 (let ((arg-list (loop for arg in args
1258 nconc `(,(intern (symbol-name arg) :keyword) ,arg))))
1259 `(with-sheet-medium (medium stream)
1260 (when (stream-recording-p stream)
1261 (let ((record
1262 ;; Hack: the coord-seq-mixin makes the assumption that, well
1263 ;; coord-seq is a coord-vector. So we morph a possible
1264 ;; coord-seq argument into a vector.
1265 (let (,@(when (member 'coord-seq args)
1266 `((coord-seq
1267 (if (vectorp coord-seq)
1268 coord-seq
1269 (coerce coord-seq 'vector))))))
1270 (make-instance ',class-name
1271 :stream stream
1272 ,@arg-list))))
1273 (stream-add-output-record stream record)))
1274 (when (stream-drawing-p stream)
1275 (,method-name medium ,@args)))))
1276
1277 ;; DEF-GRECORDING: This is the central interface through which recording
1278 ;; is implemented for drawing functions. The body provided is used to
1279 ;; compute the bounding rectangle of the rendered output. DEF-GRECORDING
1280 ;; will define a class for the output record, with slots corresponding to the
1281 ;; drawing function arguments. It also defines an INITIALIZE-INSTANCE method
1282 ;; computing the bounding rectangle of the record. It defines a method for
1283 ;; the medium drawing function specialized on output-recording-stream, which
1284 ;; is responsible for creating the output record and adding it to the stream
1285 ;; history. It also defines a REPLAY-OUTPUT-RECORD method, which calls the
1286 ;; medium drawing function based on the recorded slots.
1287
1288 (defmacro def-grecording (name ((&rest mixins) &rest args)
1289 (&key (class t)
1290 (medium-fn t)
1291 (replay-fn t)) &body body)
1292 (let ((method-name (symbol-concat '#:medium- name '*))
1293 (class-name (symbol-concat name '#:-output-record))
1294 (medium (gensym "MEDIUM"))
1295 (class-vars `((stream :initarg :stream)
1296 ,@(loop for arg in args
1297 collect `(,arg
1298 :initarg ,(intern (symbol-name arg)
1299 :keyword))))))
1300 `(progn
1301 ,@(when class
1302 `((defclass ,class-name (,@mixins standard-graphics-displayed-output-record)
1303 ,class-vars)
1304 (defmethod initialize-instance :after ((graphic ,class-name)
1305 &key)
1306 (with-slots (stream ink clipping-region
1307 line-style text-style ,@args)
1308 graphic
1309 (let* ((medium (sheet-medium stream)))
1310 (setf (rectangle-edges* graphic)
1311 (progn ,@body)))))))
1312 ,(when medium-fn
1313 `(defmethod ,method-name :around ((stream output-recording-stream) ,@args)
1314 ;; XXX STANDARD-OUTPUT-RECORDING-STREAM ^?
1315 (generate-medium-recording-body ,class-name ,method-name ,args)))
1316 ,(when replay-fn
1317 `(defmethod replay-output-record ((record ,class-name) stream
1318 &optional (region +everywhere+)
1319 (x-offset 0) (y-offset 0))
1320 (declare (ignore x-offset y-offset region))
1321 (with-slots (,@args) record
1322 (let ((,medium (sheet-medium stream))
1323 ;; is sheet a sheet-with-medium-mixin? --GB
1324 )
1325 ;; Graphics state is set up in :around method.
1326 (,method-name ,medium ,@args))))))))
1327
1328 (def-grecording draw-point ((gs-line-style-mixin) point-x point-y) ()
1329 (let ((border (graphics-state-line-style-border graphic medium)))
1330 (with-transformed-position ((medium-transformation medium) point-x point-y)
1331 (setf (slot-value graphic 'point-x) point-x
1332 (slot-value graphic 'point-y) point-y)
1333 (values (- point-x border)
1334 (- point-y border)
1335 (+ point-x border)
1336 (+ point-y border)))))
1337
1338 (defmethod* (setf output-record-position) :around
1339 (nx ny (record draw-point-output-record))
1340 (with-standard-rectangle* (:x1 x1 :y1 y1)
1341 record
1342 (with-slots (point-x point-y)
1343 record
1344 (let ((dx (- nx x1))
1345 (dy (- ny y1)))
1346 (multiple-value-prog1
1347 (call-next-method)
1348 (incf point-x dx)
1349 (incf point-y dy))))))
1350
1351 (defrecord-predicate draw-point-output-record (point-x point-y)
1352 (and (if-supplied (point-x coordinate)
1353 (coordinate= (slot-value record 'point-x) point-x))
1354 (if-supplied (point-y coordinate)
1355 (coordinate= (slot-value record 'point-y) point-y))))
1356
1357 (def-grecording draw-points ((coord-seq-mixin gs-line-style-mixin) coord-seq) ()
1358 (let ((transformed-coord-seq (transform-positions (medium-transformation medium) coord-seq))
1359 (border (graphics-state-line-style-border graphic medium)))
1360 (setf (slot-value graphic 'coord-seq) transformed-coord-seq)
1361 (coord-seq-bounds transformed-coord-seq border)))
1362
1363 (def-grecording draw-line ((gs-line-style-mixin)
1364 point-x1 point-y1 point-x2 point-y2) ()
1365 (let ((transform (medium-transformation medium))
1366 (border (graphics-state-line-style-border graphic medium)))
1367 (with-transformed-position (transform point-x1 point-y1)
1368 (with-transformed-position (transform point-x2 point-y2)
1369 (setf (slot-value graphic 'point-x1) point-x1
1370 (slot-value graphic 'point-y1) point-y1
1371 (slot-value graphic 'point-x2) point-x2
1372 (slot-value graphic 'point-y2) point-y2)
1373 (values (- (min point-x1 point-x2) border)
1374 (- (min point-y1 point-y2) border)
1375 (+ (max point-x1 point-x2) border)
1376 (+ (max point-y1 point-y2) border))))))
1377
1378 (defmethod* (setf output-record-position) :around
1379 (nx ny (record draw-line-output-record))
1380 (with-standard-rectangle* (:x1 x1 :y1 y1)
1381 record
1382 (with-slots (point-x1 point-y1 point-x2 point-y2)
1383 record
1384 (let ((dx (- nx x1))
1385 (dy (- ny y1)))
1386 (multiple-value-prog1
1387 (call-next-method)
1388 (incf point-x1 dx)
1389 (incf point-y1 dy)
1390 (incf point-x2 dx)
1391 (incf point-y2 dy))))))
1392
1393 (defrecord-predicate draw-line-output-record (point-x1 point-y1
1394 point-x2 point-y2)
1395 (and (if-supplied (point-x1 coordinate)
1396 (coordinate= (slot-value record 'point-x1) point-x1))
1397 (if-supplied (point-y1 coordinate)
1398 (coordinate= (slot-value record 'point-y1) point-y1))
1399 (if-supplied (point-x2 coordinate)
1400 (coordinate= (slot-value record 'point-x2) point-x2))
1401 (if-supplied (point-y2 coordinate)
1402 (coordinate= (slot-value record 'point-y2) point-y2))))
1403
1404 (def-grecording draw-lines ((coord-seq-mixin gs-line-style-mixin) coord-seq) ()
1405 (let ((transformed-coord-seq (transform-positions (medium-transformation medium) coord-seq))
1406 (border (graphics-state-line-style-border graphic medium)))
1407 (setf coord-seq transformed-coord-seq)
1408 (coord-seq-bounds transformed-coord-seq border)))
1409
1410 ;;; (setf output-record-position) and predicates for draw-lines-output-record
1411 ;;; are taken care of by methods on superclasses.
1412
1413 ;;; Helper function
1414 (defun normalize-coords (dx dy &optional unit)
1415 (let ((norm (sqrt (+ (* dx dx) (* dy dy)))))
1416 (cond ((= norm 0.0d0)
1417 (values 0.0d0 0.0d0))
1418 (unit
1419 (let ((scale (/ unit norm)))
1420 (values (* dx scale) (* dy scale))))
1421 (t (values (/ dx norm) (/ dy norm))))))
1422
1423 (defun polygon-record-bounding-rectangle
1424 (coord-seq closed filled line-style border miter-limit)
1425 (cond (filled
1426 (coord-seq-bounds coord-seq 0))
1427 ((eq (line-style-joint-shape line-style) :round)
1428 (coord-seq-bounds coord-seq border))
1429 (t (let* ((x1 (svref coord-seq 0))
1430 (y1 (svref coord-seq 1))
1431 (min-x x1)
1432 (min-y y1)
1433 (max-x x1)
1434 (max-y y1)
1435 (len (length coord-seq)))
1436 (unless closed
1437 (setq min-x (- x1 border) min-y (- y1 border)
1438 max-x (+ x1 border) max-y (+ y1 border)))
1439 ;; Setup for iterating over the coordinate vector. If the polygon
1440 ;; is closed deal with the extra segment.
1441 (multiple-value-bind (initial-xp initial-yp
1442 final-xn final-yn
1443 initial-index final-index)
1444 (if closed
1445 (values (svref coord-seq (- len 2))
1446 (svref coord-seq (- len 1))
1447 x1 y1
1448 0 (- len 2))
1449 (values x1 y1
1450 (svref coord-seq (- len 2))
1451 (svref coord-seq (- len 1))
1452 2 (- len 4)))
1453 (ecase (line-style-joint-shape line-style)
1454 (:miter
1455 ;;FIXME: Remove successive positively proportional segments
1456 (loop with sin-limit = (sin (* 0.5 miter-limit))
1457 and xn and yn
1458 for i from initial-index to final-index by 2
1459 for xp = initial-xp then x
1460 for yp = initial-yp then y
1461 for x = (svref coord-seq i)
1462 for y = (svref coord-seq (1+ i))
1463 do (setf (values xn yn)
1464 (if (eql i final-index)
1465 (values final-xn final-yn)
1466 (values (svref coord-seq (+ i 2))
1467 (svref coord-seq (+ i
1468 3)))))
1469 (multiple-value-bind (ex1 ey1)
1470 (normalize-coords (- x xp) (- y yp))
1471 (multiple-value-bind (ex2 ey2)
1472 (normalize-coords (- x xn) (- y yn))
1473 (let* ((cos-a (+ (* ex1 ex2) (* ey1 ey2)))
1474 (sin-a/2 (sqrt (* 0.5 (- 1.0 cos-a)))))
1475 (if (< sin-a/2 sin-limit)
1476 (let ((nx (* border
1477 (max (abs ey1) (abs ey2))))
1478 (ny (* border
1479 (max (abs ex1) (abs ex2)))))
1480 (minf min-x (- x nx))
1481 (minf min-y (- y ny))
1482 (maxf max-x (+ x nx))
1483 (maxf max-y (+ y ny)))
1484 (let ((length (/ border sin-a/2)))
1485 (multiple-value-bind (dx dy)
1486 (normalize-coords (+ ex1 ex2)
1487 (+ ey1 ey2)
1488 length)
1489 (minf min-x (+ x dx))
1490 (minf min-y (+ y dy))
1491 (maxf max-x (+ x dx))
1492 (maxf max-y (+ y dy))))))))))
1493 ((:bevel :none)
1494 (loop with xn and yn
1495 for i from initial-index to final-index by 2
1496 for xp = initial-xp then x
1497 for yp = initial-yp then y
1498 for x = (svref coord-seq i)
1499 for y = (svref coord-seq (1+ i))
1500 do (setf (values xn yn)
1501 (if (eql i final-index)
1502 (values final-xn final-yn)
1503 (values (svref coord-seq (+ i 2))
1504 (svref coord-seq (+ i
1505 3)))))
1506 (multiple-value-bind (ex1 ey1)
1507 (normalize-coords (- x xp) (- y yp))
1508 (multiple-value-bind (ex2 ey2)
1509 (normalize-coords (- x xn) (- y yn))
1510 (let ((nx (* border (max (abs ey1) (abs ey2))))
1511 (ny (* border (max (abs ex1) (abs ex2)))))
1512 (minf min-x (- x nx))
1513 (minf min-y (- y ny))
1514 (maxf max-x (+ x nx))
1515 (maxf max-y (+ y ny))))))))
1516 (unless closed
1517 (multiple-value-bind (x y)
1518 (values (svref coord-seq final-index)
1519 (svref coord-seq (1+ final-index)))
1520 (minf min-x (- x border))
1521 (minf min-y (- y border))
1522 (maxf max-x (+ x border))
1523 (maxf max-y (+ y border)))))
1524 (values min-x min-y max-x max-y)))))
1525
1526 (def-grecording draw-polygon ((coord-seq-mixin gs-line-style-mixin)
1527 coord-seq closed filled) ()
1528 (let ((transformed-coord-seq (transform-positions (medium-transformation medium) coord-seq))
1529 (border (graphics-state-line-style-border graphic medium)))
1530 (setf coord-seq transformed-coord-seq)
1531 (polygon-record-bounding-rectangle transformed-coord-seq
1532 closed filled line-style border
1533 (medium-miter-limit medium))))
1534
1535 (defrecord-predicate draw-polygon-output-record (closed filled)
1536 (and (if-supplied (closed)
1537 (eql (slot-value record 'closed) closed))
1538 (if-supplied (filled)
1539 (eql (slot-value record 'filled) filled))))
1540
1541 (def-grecording draw-rectangle ((gs-line-style-mixin)
1542 left top right bottom filled) (:medium-fn nil)
1543 (let* ((transform (medium-transformation medium))
1544 (border (graphics-state-line-style-border graphic medium))
1545 (pre-coords (expand-rectangle-coords left top right bottom))
1546 (coords (transform-positions transform pre-coords)))
1547 (setf (values left top) (transform-position transform left top))
1548 (setf (values right bottom) (transform-position transform right bottom))
1549 (polygon-record-bounding-rectangle coords t filled line-style border
1550 (medium-miter-limit medium))))
1551
1552 (defmethod medium-draw-rectangle* :around ((stream output-recording-stream) left top right bottom filled)
1553 (let ((tr (medium-transformation stream)))
1554 (if (rectilinear-transformation-p tr)
1555 (generate-medium-recording-body draw-rectangle-output-record
1556 medium-draw-rectangle*
1557 (left top right bottom filled))
1558 (medium-draw-polygon* stream
1559 (expand-rectangle-coords left top right bottom)
1560 t
1561 filled))))
1562
1563 (defmethod* (setf output-record-position) :around
1564 (nx ny (record draw-rectangle-output-record))
1565 (with-standard-rectangle* (:x1 x1 :y1 y1)
1566 record
1567 (with-slots (left top right bottom)
1568 record
1569 (let ((dx (- nx x1))
1570 (dy (- ny y1)))
1571 (multiple-value-prog1
1572 (call-next-method)
1573 (incf left dx)
1574 (incf top dy)
1575 (incf right dx)
1576 (incf bottom dy))))))
1577
1578 (defrecord-predicate draw-rectangle-output-record (left top right bottom filled)
1579 (and (if-supplied (left coordinate)
1580 (coordinate= (slot-value record 'left) left))
1581 (if-supplied (top coordinate)
1582 (coordinate= (slot-value record 'top) top))
1583 (if-supplied (right coordinate)
1584 (coordinate= (slot-value record 'right) right))
1585 (if-supplied (bottom coordinate)
1586 (coordinate= (slot-value record 'bottom) bottom))
1587 (if-supplied (filled)
1588 (eql (slot-value record 'filled) filled))))
1589
1590 (def-grecording draw-ellipse ((gs-line-style-mixin)
1591 center-x center-y
1592 radius-1-dx radius-1-dy radius-2-dx radius-2-dy
1593 start-angle end-angle filled) ()
1594 (let ((transform (medium-transformation medium)))
1595 (setf (values center-x center-y)
1596 (transform-position transform center-x center-y))
1597 (setf (values radius-1-dx radius-1-dy)
1598 (transform-distance transform radius-1-dx radius-1-dy))
1599 (setf (values radius-2-dx radius-2-dy)
1600 (transform-distance transform radius-2-dx radius-2-dy))
1601 ;; I think this should be untransform-angle below, as the ellipse angles
1602 ;; go counter-clockwise in screen coordinates, whereas our transformations
1603 ;; rotate clockwise in the default coorinate system.. this is quite possibly
1604 ;; wrong depending on how one reads the spec, but just reversing it here
1605 ;; will break other things. -Hefner
1606 (setf start-angle (untransform-angle transform start-angle))
1607 (setf end-angle (untransform-angle transform end-angle))
1608 (when (reflection-transformation-p transform)
1609 (rotatef start-angle end-angle))
1610 (multiple-value-bind (min-x min-y max-x max-y)
1611 (bounding-rectangle* (make-ellipse* center-x center-y
1612 radius-1-dx radius-1-dy
1613 radius-2-dx radius-2-dy
1614 :start-angle start-angle
1615 :end-angle end-angle))
1616 (if filled
1617 (values min-x min-y max-x max-y)
1618 (let ((border (graphics-state-line-style-border graphic medium)))
1619 (values (- min-x border)
1620 (- min-y border)
1621 (+ max-x border)
1622 (+ max-y border)))))))
1623
1624 (defmethod* (setf output-record-position) :around
1625 (nx ny (record draw-ellipse-output-record))
1626 (with-standard-rectangle* (:x1 x1 :y1 y1)
1627 record
1628 (with-slots (center-x center-y)
1629 record
1630 (let ((dx (- nx x1))
1631 (dy (- ny y1)))
1632 (multiple-value-prog1
1633 (call-next-method)
1634 (incf center-x dx)
1635 (incf center-y dy))))))
1636
1637 (defrecord-predicate draw-ellipse-output-record (center-x center-y)
1638 (and (if-supplied (center-x coordinate)
1639 (coordinate= (slot-value record 'center-x) center-x))
1640 (if-supplied (center-y coordinate)
1641 (coordinate= (slot-value record 'center-y) center-y))))
1642
1643 ;;;; Patterns
1644
1645 ;;; The Spec says that "transformation only affects the position at
1646 ;;; which the pattern is drawn, not the pattern itself"
1647 (def-grecording draw-pattern (() pattern x y) ()
1648 (let ((width (pattern-width pattern))
1649 (height (pattern-height pattern))
1650 (transform (medium-transformation medium)))
1651 (setf (values x y) (transform-position transform x y))
1652 (values x y (+ x width) (+ y height))))
1653
1654 (defmethod* (setf output-record-position) :around
1655 (nx ny (record draw-pattern-output-record))
1656 (with-standard-rectangle* (:x1 x1 :y1 y1)
1657 record
1658 (with-slots (x y)
1659 record
1660 (let ((dx (- nx x1))
1661 (dy (- ny y1)))
1662 (multiple-value-prog1
1663 (call-next-method)
1664 (incf x dx)
1665 (incf y dy))))))
1666
1667 (defrecord-predicate draw-pattern-output-record (x y pattern)
1668 ;; ### I am not so sure about the correct usage of DEFRECORD-PREDICATE
1669 ;; --GB 2003-08-15
1670 (and (if-supplied (x coordinate)
1671 (coordinate= (slot-value record 'x) x))
1672 (if-supplied (y coordinate)
1673 (coordinate= (slot-value record 'y) y))
1674 (if-supplied (pattern pattern)
1675 (eq (slot-value record 'pattern) pattern))))
1676
1677 ;;;; Text
1678
1679 (def-grecording draw-text ((gs-text-style-mixin) string point-x point-y start end
1680 align-x align-y toward-x toward-y transform-glyphs) ()
1681 ;; FIXME!!! Text direction.
1682 ;; FIXME: Multiple lines.
1683 (let* ((text-style (graphics-state-text-style graphic))
1684 (width (if (characterp string)
1685 (stream-character-width stream string :text-style text-style)
1686 (stream-string-width stream string
1687 :start start :end end
1688 :text-style text-style)) )
1689 (ascent (text-style-ascent text-style (sheet-medium stream)))
1690 (descent (text-style-descent text-style (sheet-medium stream)))
1691 (height (+ ascent descent))
1692 (transform (medium-transformation medium)))
1693 (setf (values point-x point-y)
1694 (transform-position transform point-x point-y))
1695 (multiple-value-bind (left top right bottom)
1696 (text-bounding-rectangle* medium string
1697 :start start :end end :text-style text-style)
1698 (ecase align-x
1699 (:left (incf left point-x) (incf right point-x))
1700 (:right (incf left (- point-x width)) (incf right (- point-x width)))
1701 (:center (incf left (- point-x (round width 2)))
1702 (incf right (- point-x (round width 2)))))
1703 (ecase align-y
1704 (:baseline (incf top point-y) (incf bottom point-y))
1705 (:top (incf top (+ point-y ascent))
1706 (incf bottom (+ point-y ascent)))
1707 (:bottom (incf top (- point-y descent))
1708 (incf bottom (- point-y descent)))
1709 (:center (incf top (+ point-y (ceiling (- ascent descent) 2)))
1710 (incf bottom (+ point-y (ceiling (- ascent descent) 2)))))
1711 (values left top right bottom))))
1712
1713 (defmethod* (setf output-record-position) :around
1714 (nx ny (record draw-text-output-record))
1715 (with-standard-rectangle* (:x1 x1 :y1 y1)
1716 record
1717 (with-slots (point-x point-y toward-x toward-y)
1718 record
1719 (let ((dx (- nx x1))
1720 (dy (- ny y1)))
1721 (multiple-value-prog1
1722 (call-next-method)
1723 (incf point-x dx)
1724 (incf point-y dy)
1725 (incf toward-x dx)
1726 (incf toward-y dy))))))
1727
1728 (defrecord-predicate draw-text-output-record
1729 (string start end point-x point-y align-x align-y toward-x toward-y
1730 transform-glyphs)
1731 (and (if-supplied (string)
1732 (string= (slot-value record 'string) string))
1733 (if-supplied (start)
1734 (eql (slot-value record 'start) start))
1735 (if-supplied (end)
1736 (eql (slot-value record 'end) end))
1737 (if-supplied (point-x coordinate)
1738 (coordinate= (slot-value record 'point-x) point-x))
1739 (if-supplied (point-y coordinate)
1740 (coordinate= (slot-value record 'point-y) point-y))
1741 (if-supplied (align-x)
1742 (eq (slot-value record 'align-x) align-x))
1743 (if-supplied (align-y)
1744 (eq (slot-value record 'align-y) align-y))
1745 (if-supplied (toward-x coordinate)
1746 (coordinate= (slot-value record 'toward-x) toward-x))
1747 (if-supplied (toward-y coordinate)
1748 (coordinate= (slot-value record 'toward-y) toward-y))
1749 (if-supplied (transform-glyphs)
1750 (eq (slot-value record 'transform-glyphs) transform-glyphs))))
1751
1752 ;;; 16.3.3. Text Displayed Output Record
1753
1754 (defclass styled-string (gs-text-style-mixin gs-clip-mixin gs-ink-mixin)
1755 ((start-x :initarg :start-x)
1756 (string :initarg :string :reader styled-string-string)))
1757
1758 (defmethod output-record-equal and ((record styled-string)
1759 (record2 styled-string))
1760 (and (coordinate= (slot-value record 'start-x)
1761 (slot-value record2 'start-x))
1762 (string= (slot-value record 'string)
1763 (slot-value record2 'string))))
1764
1765 (defclass standard-text-displayed-output-record
1766 (text-displayed-output-record standard-displayed-output-record)
1767 ((initial-x1 :initarg :start-x)
1768 (initial-y1 :initarg :start-y)
1769 (strings :initform nil)
1770 (baseline :initform 0)
1771 (width :initform 0)
1772 (max-height :initform 0)
1773 ;; FIXME (or rework this comment): CLIM does not separate the
1774 ;; notions of the text width and the bounding box; however, we need
1775 ;; to, because some fonts will render outside the logical
1776 ;; coordinates defined by the start position and the width. LEFT
1777 ;; and RIGHT here (and below) deal with this in a manner completely
1778 ;; hidden from the user. (should we export
1779 ;; TEXT-BOUNDING-RECTANGLE*?)
1780 (left :initarg :start-x)
1781 (right :initarg :start-x)
1782 (start-x :initarg :start-x)
1783 (start-y :initarg :start-y)
1784 (end-x :initarg :start-x)
1785 (end-y :initarg :start-y)
1786 (wrapped :initform nil
1787 :accessor text-record-wrapped)
1788 (medium :initarg :medium :initform nil)))
1789
1790 (defmethod initialize-instance :after
1791 ((obj standard-text-displayed-output-record) &key stream)
1792 (when stream
1793 (setf (slot-value obj 'medium) (sheet-medium stream))))
1794
1795 ;;; Forget match-output-records-1 for standard-text-displayed-output-record; it
1796 ;;; doesn't make much sense because these records have state that is not
1797 ;;; initialized via initargs.
1798
1799 (defmethod output-record-equal and
1800 ((record standard-text-displayed-output-record)
1801 (record2 standard-text-displayed-output-record))
1802 (with-slots
1803 (initial-x1 initial-y1 start-x start-y left right end-x end-y wrapped strings)
1804 record2
1805 (and (coordinate= (slot-value record 'initial-x1) initial-x1)
1806 (coordinate= (slot-value record 'initial-y1) initial-y1)
1807 (coordinate= (slot-value record 'start-x) start-x)
1808 (coordinate= (slot-value record 'start-y) start-y)
1809 (coordinate= (slot-value record 'left) left)
1810 (coordinate= (slot-value record 'right) right)
1811 (coordinate= (slot-value record 'end-x) end-x)
1812 (coordinate= (slot-value record 'end-y) end-y)
1813 (eq (slot-value record 'wrapped) wrapped)
1814 (coordinate= (slot-value record 'baseline)
1815 (slot-value record2 'baseline))
1816 (eql (length (slot-value record 'strings)) (length strings));XXX
1817 (loop for s1 in (slot-value record 'strings)
1818 for s2 in strings
1819 always (output-record-equal s1 s2)))))
1820
1821 (defmethod print-object ((self standard-text-displayed-output-record) stream)
1822 (print-unreadable-object (self stream :type t :identity t)
1823 (with-slots (start-x start-y strings) self
1824 (format stream "~D,~D ~S"
1825 start-x start-y
1826 (mapcar #'styled-string-string strings)))))
1827
1828 (defmethod* (setf output-record-position) :around
1829 (nx ny (record standard-text-displayed-output-record))
1830 (with-standard-rectangle* (:x1 x1 :y1 y1)
1831 record
1832 (with-slots (start-x start-y end-x end-y strings baseline)
1833 record
1834 (let ((dx (- nx x1))
1835 (dy (- ny y1)))
1836 (multiple-value-prog1
1837 (call-next-method)
1838 (incf start-x dx)
1839 (incf start-y dy)
1840 (incf end-x dx)
1841 (incf end-y dy)
1842 ;(incf baseline dy)
1843 (loop for s in strings
1844 do (incf (slot-value s 'start-x) dx)))))))
1845
1846 (defmethod replay-output-record ((record standard-text-displayed-output-record)
1847 stream
1848 &optional region (x-offset 0) (y-offset 0))
1849 (declare (ignore region x-offset y-offset))
1850 (with-slots (strings baseline max-height start-y wrapped)
1851 record
1852 (with-sheet-medium (medium stream) ;is sheet a sheet-with-medium-mixin? --GB
1853 ;; FIXME:
1854 ;; 1. SLOT-VALUE...
1855 ;; 2. It should also save a "current line".
1856 (setf (slot-value stream 'baseline) baseline)
1857 (loop for substring in strings
1858 do (with-slots (start-x string)
1859 substring
1860 (setf (stream-cursor-position stream)
1861 (values start-x start-y))
1862 ;; FIXME: a bit of an abstraction inversion. Should
1863 ;; the styled strings here not simply be output
1864 ;; records? Then we could just replay them and all
1865 ;; would be well. -- CSR, 20060528.
1866 (with-drawing-options (stream
1867 :ink (graphics-state-ink substring)
1868 :clipping-region (graphics-state-clip substring)
1869 :text-style (graphics-state-text-style substring))
1870 (stream-write-output stream string nil))))
1871 (when wrapped ; FIXME
1872 (draw-rectangle* medium
1873 (+ wrapped 0) start-y
1874 (+ wrapped 4) (+ start-y max-height)
1875 :ink +foreground-ink+
1876 :filled t)))))
1877
1878 (defmethod output-record-start-cursor-position
1879 ((record standard-text-displayed-output-record))
1880 (with-slots (start-x start-y) record
1881 (values start-x start-y)))
1882
1883 (defmethod output-record-end-cursor-position
1884 ((record standard-text-displayed-output-record))
1885 (with-slots (end-x end-y) record
1886 (values end-x end-y)))
1887
1888 (defmethod tree-recompute-extent
1889 ((text-record standard-text-displayed-output-record))
1890 (with-standard-rectangle* (:y1 y1)
1891 text-record
1892 (with-slots (max-height left right)
1893 text-record
1894 (setf (rectangle-edges* text-record)
1895 (values (coordinate left)
1896 y1
1897 (coordinate right)
1898 (coordinate (+ y1 max-height))))))
1899 text-record)
1900
1901 (defmethod add-character-output-to-text-record ; XXX OAOO with ADD-STRING-...
1902 ((text-record standard-text-displayed-output-record)
1903 character text-style char-width height new-baseline)
1904 (with-slots (strings baseline width max-height left right start-y end-x end-y medium)
1905 text-record
1906 (if (and strings
1907 (let ((string (last1 strings)))
1908 (match-output-records string
1909 :text-style text-style
1910 :ink (medium-ink medium)
1911 :clipping-region (medium-clipping-region
1912 medium))))
1913 (vector-push-extend character (slot-value (last1 strings) 'string))
1914 (nconcf strings
1915 (list (make-instance
1916 'styled-string
1917 :start-x end-x
1918 :text-style text-style
1919 :medium medium ; pick up ink and clipping region
1920 :string (make-array 1 :initial-element character
1921 :element-type 'character
1922 :adjustable t
1923 :fill-pointer t)))))
1924 (multiple-value-bind (minx miny maxx maxy)
1925 (text-bounding-rectangle* medium character :text-style text-style)
1926 (declare (ignore miny maxy))
1927 (setq baseline (max baseline new-baseline)
1928 ;; KLUDGE: note END-X here is really START-X of the new
1929 ;; string
1930 left (min left (+ end-x minx))
1931 end-x (+ end-x char-width)
1932 right (+ end-x (max 0 (- maxx char-width)))
1933 max-height (max max-height height)
1934 end-y (max end-y (+ start-y max-height))
1935 width (+ width char-width))))
1936 (tree-recompute-extent text-record))
1937
1938 (defmethod add-string-output-to-text-record
1939 ((text-record standard-text-displayed-output-record)
1940 string start end text-style string-width height new-baseline)
1941 (setf end (or end (length string)))
1942 (let ((length (max 0 (- end start))))
1943 (cond
1944 ((eql length 1)
1945 (add-character-output-to-text-record text-record
1946 (aref string start)
1947 text-style
1948 string-width height new-baseline))
1949 (t (with-slots (strings baseline width max-height left right start-y end-x end-y
1950 medium)
1951 text-record
1952 (let ((styled-string (make-instance
1953 'styled-string
1954 :start-x end-x
1955 :text-style text-style
1956 :medium medium
1957 :string (make-array length
1958 :element-type 'character
1959 :adjustable t
1960 :fill-pointer t))))
1961 (nconcf strings (list styled-string))
1962 (replace (styled-string-string styled-string) string
1963 :start2 start :end2 end))
1964 (multiple-value-bind (minx miny maxx maxy)
1965 (text-bounding-rectangle* medium string
1966 :text-style text-style
1967 :start start :end end)
1968 (declare (ignore miny maxy))
1969 (setq baseline (max baseline new-baseline)
1970 ;; KLUDGE: note that END-X here really means
1971 ;; START-X of the new string.
1972 left (min left (+ end-x minx))
1973 end-x (+ end-x string-width)
1974 right (+ end-x (max 0 (- maxx string-width)))
1975 max-height (max max-height height)
1976 end-y (max end-y (+ start-y max-height))
1977 width (+ width string-width))))
1978 (tree-recompute-extent text-record)))))
1979
1980 (defmethod text-displayed-output-record-string
1981 ((record standard-text-displayed-output-record))
1982 (with-slots (strings) record
1983 (if (= 1 (length strings))
1984 (styled-string-string (first strings))
1985 (with-output-to-string (result)
1986 (loop for styled-string in strings
1987 do (write-string (styled-string-string styled-string) result))))))
1988
1989 ;;; 16.3.4. Top-Level Output Records
1990 (defclass stream-output-history-mixin ()
1991 ((stream :initarg :stream :reader output-history-stream)))
1992
1993 (defclass standard-sequence-output-history
1994 (standard-sequence-output-record stream-output-history-mixin)
1995 ())
1996
1997 (defclass standard-tree-output-history
1998 (standard-tree-output-record stream-output-history-mixin)
1999 ())
2000
2001 ;;; 16.4. Output Recording Streams
2002 (defclass standard-output-recording-stream (output-recording-stream)
2003 ((recording-p :initform t :reader stream-recording-p)
2004 (drawing-p :initform t :accessor stream-drawing-p)
2005 (output-history :initform (make-instance 'standard-tree-output-history)
2006 :reader stream-output-history)
2007 (current-output-record :accessor stream-current-output-record)
2008 (current-text-output-record :initform nil
2009 :accessor stream-current-text-output-record)
2010 (local-record-p :initform t
2011 :documentation "This flag is used for dealing with streams outputting strings char-by-char.")))
2012
2013 (defmethod initialize-instance :after
2014 ((stream standard-output-recording-stream) &rest args)
2015 (declare (ignore args))
2016 (let ((history (make-instance 'standard-tree-output-history :stream stream)))
2017 (setf (slot-value stream 'output-history) history
2018 (stream-current-output-record stream) history)))
2019
2020 ;;; Used in initializing clim-stream-pane
2021
2022 (defmethod reset-output-history ((stream
2023 standard-output-recording-stream))
2024 (setf (slot-value stream 'output-history)
2025 (make-instance 'standard-tree-output-history :stream stream))
2026 (setf (stream-current-output-record stream) (stream-output-history stream)))
2027
2028 ;;; 16.4.1 The Output Recording Stream Protocol
2029 (defmethod (setf stream-recording-p)
2030 (recording-p (stream standard-output-recording-stream))
2031 (let ((old-val (slot-value stream 'recording-p)))
2032 (setf (slot-value stream 'recording-p) recording-p)
2033 (when (not (eq old-val recording-p))
2034 (stream-close-text-output-record stream))
2035 recording-p))
2036
2037 (defmethod stream-add-output-record
2038 ((stream standard-output-recording-stream) record)
2039 (add-output-record record (stream-current-output-record stream)))
2040
2041 (defmethod stream-replay
2042 ((stream standard-output-recording-stream) &optional region)
2043 (replay (stream-output-history stream) stream region))
2044
2045 (defun output-record-ancestor-p (ancestor child)
2046 (loop for record = child then parent
2047 for parent = (output-record-parent record)
2048 when (eq parent nil) do (return nil)
2049 when (eq parent ancestor) do (return t)))
2050
2051 (defun rounded-bounding-rectangle (region)
2052 ;; return a bounding rectangle whose coordinates have been rounded to
2053 ;; lock into the pixel grid. Includes some extra safety to make
2054 ;; sure antialiasing around the theoretical limits are included, too.
2055 (with-bounding-rectangle* (x1 y1 x2 y2) region
2056 (make-rectangle* (floor (- x1 0.5))
2057 (floor (- y1 0.5))
2058 (ceiling (+ x2 0.5))
2059 (ceiling (+ y2 0.5)))))
2060
2061 (defmethod erase-output-record (record (stream standard-output-recording-stream)
2062 &optional (errorp t))
2063 (letf (((stream-recording-p stream) nil))
2064 (let ((region (rounded-bounding-rectangle record)))
2065 (with-bounding-rectangle* (x1 y1 x2 y2) region
2066 (if (output-record-ancestor-p (stream-output-history stream) record)
2067 (progn
2068 (delete-output-record record (output-record-parent record))
2069 (with-output-recording-options (stream :record nil)
2070 (draw-rectangle* stream x1 y1 x2 y2 :ink +background-ink+))
2071 (stream-replay stream region))
2072 (when errorp
2073 (error "~S is not contained in ~S." record stream)))))))
2074
2075 ;;; 16.4.3. Text Output Recording
2076 (defmethod stream-text-output-record
2077 ((stream standard-output-recording-stream) text-style)
2078 (declare (ignore text-style))
2079 (let ((record (stream-current-text-output-record stream)))
2080 (unless (and record (typep record 'standard-text-displayed-output-record))
2081 (multiple-value-bind (cx cy) (stream-cursor-position stream)
2082 (setf record (make-instance 'standard-text-displayed-output-record
2083 :x-position cx :y-position cy
2084 :start-x cx :start-y cy
2085 :stream stream)
2086 (stream-current-text-output-record stream) record)))
2087 record))
2088
2089 (defmethod stream-close-text-output-record
2090 ((stream standard-output-recording-stream))
2091 (let ((record (stream-current-text-output-record stream)))
2092 (when record
2093 (setf (stream-current-text-output-record stream) nil)
2094 #|record stream-current-cursor-position to (end-x record) - already done|#
2095 (stream-add-output-record stream record))))
2096
2097 (defmethod stream-add-character-output
2098 ((stream standard-output-recording-stream)
2099 character text-style width height baseline)
2100 (add-character-output-to-text-record
2101 (stream-text-output-record stream text-style)
2102 character text-style width height baseline))
2103
2104 (defmethod stream-add-string-output ((stream standard-output-recording-stream)
2105 string start end text-style
2106 width height baseline)
2107 (add-string-output-to-text-record (stream-text-output-record stream
2108 text-style)
2109 string start end text-style
2110 width height baseline))
2111
2112 ;;; Text output catching methods
2113 (defmacro without-local-recording (stream &body body)
2114 `(letf (((slot-value ,stream 'local-record-p) nil))
2115 ,@body))
2116
2117 (defmethod stream-write-output :around
2118 ((stream standard-output-recording-stream)
2119 line
2120 string-width
2121 &optional (start 0) end)
2122 (when (and (stream-recording-p stream)
2123 (slot-value stream 'local-record-p))
2124 (let* ((medium (sheet-medium stream))
2125 (text-style (medium-text-style medium))
2126 (height (text-style-height text-style medium))
2127 (ascent (text-style-ascent text-style medium)))
2128 (if (characterp line)
2129 (stream-add-character-output stream line text-style
2130 (stream-character-width
2131 stream line :text-style text-style)
2132 height
2133 ascent)
2134 (stream-add-string-output stream line start end text-style
2135 (or string-width
2136 (stream-string-width stream line
2137 :start start :end end
2138 :text-style text-style))
2139 height
2140 ascent))))
2141 (when (stream-drawing-p stream)
2142 (without-local-recording stream
2143 (call-next-method))))
2144
2145 #+nil
2146 (defmethod stream-write-char :around ((stream standard-output-recording-stream) char)
2147 (when (and (stream-recording-p stream)
2148 (slot-value stream 'local-record-p))
2149 (if (or (eql char #\return)
2150
2151 (stream-close-text-output-record stream)
2152 (let* ((medium (sheet-medium stream))
2153 (text-style (medium-text-style medium)))
2154 (stream-add-character-output stream char text-style
2155 (stream-character-width stream char :text-style text-style)
2156 (text-style-height text-style medium)
2157 (text-style-ascent text-style medium)))))
2158 (without-local-recording stream
2159 (call-next-method))))
2160
2161 #+nil
2162 (defmethod stream-write-string :around ((stream standard-output-recording-stream) string
2163 &optional (start 0) end)
2164 (when (and (stream-recording-p stream)
2165 (slot-value stream 'local-record-p))
2166 (let* ((medium (sheet-medium stream))
2167 (text-style (medium-text-style medium)))
2168 (stream-add-string-output stream string start end text-style
2169 (stream-string-width stream string
2170 :start start :end end
2171 :text-style text-style)
2172 (text-style-height text-style medium)
2173 (text-style-ascent text-style medium))))
2174 (without-local-recording stream
2175 (call-next-method)))
2176
2177
2178 (defmethod stream-finish-output :after ((stream standard-output-recording-stream))
2179 (stream-close-text-output-record stream))
2180
2181 (defmethod stream-force-output :after ((stream standard-output-recording-stream))
2182 (stream-close-text-output-record stream))
2183
2184 (defmethod stream-terpri :after ((stream standard-output-recording-stream))
2185 (stream-close-text-output-record stream))
2186
2187 (defmethod* (setf stream-cursor-position) :after (x y (stream standard-output-recording-stream))
2188 (declare (ignore x y))
2189 (stream-close-text-output-record stream))
2190
2191 ;(defmethod stream-set-cursor-position :after ((stream standard-output-recording-stream))
2192 ; (stream-close-text-output-record stream))
2193
2194 (defmethod stream-wrap-line :before ((stream standard-output-recording-stream))
2195 (when (stream-recording-p stream)
2196 (setf (text-record-wrapped (stream-text-output-record stream nil)) ; FIXME!
2197 (stream-text-margin stream))))
2198
2199 ;;; 16.4.4. Output Recording Utilities
2200
2201 (defmethod invoke-with-output-recording-options
2202 ((stream output-recording-stream) continuation record draw)
2203 "Calls CONTINUATION on STREAM enabling or disabling recording and drawing
2204 according to the flags RECORD and DRAW."
2205 (letf (((stream-recording-p stream) record)
2206 ((stream-drawing-p stream) draw))
2207 (funcall continuation stream)))
2208
2209 (defmethod invoke-with-new-output-record ((stream output-recording-stream)
2210 continuation record-type
2211 constructor
2212 &key parent)
2213 (declare (ignore record-type))
2214 (stream-close-text-output-record stream)
2215 (let ((new-record (funcall constructor)))
2216 (letf (((stream-current-output-record stream) new-record))
2217 ;; Should we switch on recording? -- APD
2218 (funcall continuation stream new-record)
2219 (finish-output stream))
2220 (if parent
2221 (add-output-record new-record parent)
2222 (stream-add-output-record stream new-record))
2223 new-record))
2224
2225 (defmethod invoke-with-new-output-record ((stream output-recording-stream)
2226 continuation record-type
2227 (constructor null)
2228 &rest initargs
2229 &key parent)
2230 (with-keywords-removed (initargs (:parent))
2231 (stream-close-text-output-record stream)
2232 (let ((new-record (apply #'make-instance record-type initargs)))
2233 (letf (((stream-current-output-record stream) new-record))
2234 ;; Should we switch on recording? -- APD
2235 (funcall continuation stream new-record)
2236 (finish-output stream))
2237 (if parent
2238 (add-output-record new-record parent)
2239 (stream-add-output-record stream new-record))
2240 new-record)))
2241
2242 (defmethod invoke-with-output-to-output-record
2243 ((stream output-recording-stream) continuation record-type constructor
2244 &key)
2245 (declare (ignore record-type))
2246 (stream-close-text-output-record stream)
2247 (let ((new-record (funcall constructor)))
2248 (with-output-recording-options (stream :record t :draw nil)
2249 (letf (((stream-current-output-record stream) new-record)
2250 ((stream-cursor-position stream) (values 0 0)))
2251 (funcall continuation stream new-record)
2252 (finish-output stream)))
2253 new-record))
2254
2255 (defmethod invoke-with-output-to-output-record
2256 ((stream output-recording-stream) continuation record-type (constructor null)
2257 &rest initargs)
2258 (stream-close-text-output-record stream)
2259 (let ((new-record (apply #'make-instance record-type initargs)))
2260 (with-output-recording-options (stream :record t :draw nil)
2261 (letf (((stream-current-output-record stream) new-record)
2262 ((stream-cursor-position stream) (values 0 0)))
2263 (funcall continuation stream new-record)
2264 (finish-output stream)))
2265 new-record))
2266
2267 (defmethod make-design-from-output-record (record)
2268 ;; FIXME
2269 (declare (ignore record))
2270 (error "Not implemented."))
2271
2272
2273 ;;; Additional methods
2274 (defmethod scroll-vertical :around ((stream output-recording-stream) dy)
2275 (declare (ignore dy))
2276 (with-output-recording-options (stream :record nil)
2277 (call-next-method)))
2278
2279 (defmethod scroll-horizontal :around ((stream output-recording-stream) dx)
2280 (declare (ignore dx))
2281 (with-output-recording-options (stream :record nil)
2282 (call-next-method)))
2283
2284 ;;; Helper function to break some infinite recursion issues with
2285 ;;; handle-repaint vs. redisplay-frame-pane (in the Listener, that
2286 ;;; is; is this the right place for the fix? )
2287
2288 ;;; FIXME: Change things so the rectangle below is only drawn in response
2289 ;;; to explicit repaint requests from the user, not exposes from X
2290 ;;; FIXME: Use DRAW-DESIGN*, that is fix DRAW-DESIGN*.
2291
2292 (defun %handle-repaint (stream region)
2293 (when (output-recording-stream-p stream)
2294 (unless (region-equal region +nowhere+) ; ignore repaint requests for +nowhere+
2295 (let ((region (if (region-equal region +everywhere+)
2296 (sheet-region stream) ; fallback to the sheet's region for +everwhere+
2297 (bounding-rectangle region))))
2298 (with-bounding-rectangle* (x1 y1 x2 y2) region
2299 (with-output-recording-options (stream :record nil)
2300 (draw-rectangle* stream x1 y1 x2 y2 :filled t :ink +background-ink+)))
2301 (stream-replay stream region)))))
2302
2303 (defmethod handle-repaint ((stream output-recording-stream) region)
2304 (%handle-repaint stream region))
2305
2306 (defmethod scroll-extent :around ((stream output-recording-stream) x y)
2307 (declare (ignore x y))
2308 (when (stream-drawing-p stream)
2309 (call-next-method)))
2310
2311 ;;; ----------------------------------------------------------------------------
2312 ;;; Complicated, underspecified...
2313 ;;;
2314 ;;; From examining old Genera documentation, I believe that
2315 ;;; with-room-for-graphics is supposed to set the medium transformation to
2316 ;;; give the desired coordinate system; i.e., it doesn't preserve any
2317 ;;; rotation, scaling or translation in the current medium transformation.
2318 (defmethod invoke-with-room-for-graphics (cont stream
2319 &key (first-quadrant t)
2320 height
2321 (move-cursor t)
2322 (record-type
2323 'standard-sequence-output-record))
2324 ;; I am not sure what exactly :height should do.
2325 ;; --GB 2003-05-25
2326 ;; The current behavior is consistent with 'classic' CLIM
2327 ;; --Hefner 2004-06-19
2328 ;; Don't know if it still is :)
2329 ;; -- Moore 2005-01-26
2330 (multiple-value-bind (cx cy)
2331 (stream-cursor-position stream)
2332 (with-sheet-medium (medium stream)
2333 (letf (((medium-transformation medium)
2334 (if first-quadrant
2335 (make-scaling-transformation 1 -1)
2336 +identity-transformation+)))
2337 (let ((record (with-output-to-output-record (stream record-type)
2338 (funcall cont stream))))
2339 ;; Bounding rectangle is in sheet coordinates!
2340 (with-bounding-rectangle* (x1 y1 x2 y2)
2341 record
2342 (declare (ignore x2))
2343 (if first-quadrant
2344 (setf (output-record-position record)
2345 (values (max cx (+ cx x1))
2346 (if height
2347 (max cy (+ cy (- height (- y2 y1))))
2348 cy)))
2349 (setf (output-record-position record)
2350 (values (max cx (+ cx x1)) (max cy (+ cy y1)))))
2351 (when (stream-recording-p stream)
2352 (stream-add-output-record stream record))
2353 (when (stream-drawing-p stream)
2354 (replay record stream))
2355 (if move-cursor
2356 (let ((record-height (- y2 y1)))
2357 (setf (stream-cursor-position stream)
2358 (values cx
2359 (if first-quadrant
2360 (+ cy (max (- y1)
2361 (or height 0)
2362 record-height))
2363 (+ cy (max (or height 0)
2364 record-height))))))
2365 (setf (stream-cursor-position stream) (values cx cy)))
2366 record))))))
2367
2368
2369
2370 (defmethod repaint-sheet ((sheet output-recording-stream) region)
2371 (map-over-sheets-overlapping-region #'(lambda (s)
2372 (%handle-repaint s region))
2373 sheet
2374 region))
2375
2376 ;;; ----------------------------------------------------------------------------
2377 ;;; Baseline
2378 ;;;
2379
2380 (defmethod output-record-baseline ((record output-record))
2381 "Fall back method"
2382 (with-bounding-rectangle* (x1 y1 x2 y2)
2383 record
2384 (declare (ignore x1 x2))
2385 (values (- y2 y1) nil)))
2386
2387 (defmethod output-record-baseline ((record standard-text-displayed-output-record))
2388 (with-slots (baseline) record
2389 (values
2390 baseline
2391 t)))
2392
2393 (defmethod output-record-baseline ((record compound-output-record))
2394 (map-over-output-records (lambda (sub-record)
2395 (multiple-value-bind (baseline definitive)
2396 (output-record-baseline sub-record)
2397 (when definitive
2398 (return-from output-record-baseline
2399 (values baseline t)))))
2400 record)
2401 (call-next-method))
2402
2403 ;;; ----------------------------------------------------------------------------
2404 ;;; copy-textual-output
2405 ;;;
2406
2407 (defun copy-textual-output-history (window stream &optional region record)
2408 (unless region (setf region +everywhere+))
2409 (unless record (setf record (stream-output-history window)))
2410 (let* ((text-style (medium-default-text-style window))
2411 (char-width (stream-character-width window #\n :text-style text-style))
2412 (line-height (+ (stream-line-height window :text-style text-style)
2413 (stream-vertical-spacing window))))
2414 #+NIL
2415 (print (list char-width line-height
2416 (stream-line-height window :text-style text-style)
2417 (stream-vertical-spacing window))
2418 *trace-output*)
2419 ;; humble first ...
2420 (let ((cy nil)
2421 (cx 0))
2422 (labels ((grok-record (record)
2423 (cond ((typep record 'standard-text-displayed-output-record)
2424 (with-slots (start-y start-x end-x strings) record
2425 (setf cy (or cy start-y))
2426 #+NIL
2427 (print (list (list cx cy)
2428 (list start-x end-x start-y))
2429 *trace-output*)
2430 (when (> start-y cy)
2431 (dotimes (k (round (- start-y cy) line-height))
2432 (terpri stream))
2433 (setf cy start-y
2434 cx 0))
2435 (dotimes (k (round (- start-x cx) char-width))
2436 (princ " " stream))
2437 (setf cx end-x)
2438 (dolist (string strings)
2439 (with-slots (string) string
2440 (princ string stream))
2441 #+NIL
2442 (print (list start-x start-y string)
2443 *trace-output*))))
2444 (t
2445 (map-over-output-records-overlapping-region #'grok-record
2446 record region)))))
2447 (grok-record record)))))
2448
2449 ;;; Debugging hacks
2450
2451 (defmethod count-records (r)
2452 (declare (ignore r))
2453 1)
2454
2455 (defmethod <