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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.138 - (show annotations)
Sat Feb 2 19:03:00 2008 UTC (6 years, 2 months ago) by thenriksen
Branch: MAIN
Changes since 1.137: +4 -2 lines
Output recording bandaids:

Use CLIM 2.2 region default for replay.

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