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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5