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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5