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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.111 - (show annotations)
Fri Aug 13 14:10:11 2004 UTC (9 years, 8 months ago) by moore
Branch: MAIN
Changes since 1.110: +11 -6 lines
Fixers for several bugs revealed by indented-lists.lisp from the CLIM
repository. The mechanism for establishing a current updating-output
record for the purposes of cache lookup was broken. There was a bug
in compute-difference-set, and also a problem with recording the
current stream state of an updating-output record during redisplay.

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

  ViewVC Help
Powered by ViewVC 1.1.5