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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.57 - (show annotations)
Tue Jan 28 08:17:41 2003 UTC (11 years, 2 months ago) by moore
Branch: MAIN
Changes since 1.56: +662 -298 lines
Output record values are stored in stream coordinates, not user (post
medium transformation) coordinates.

All medium state values are stored in output records by individual
mixin classes that are assembled for each output record type.

Medium parameters are only set in replay-output-record, not set and
restored.  Medium values are set/restored in replay.

Checkpoint of incremental redisplay, currently disabled.

Implement match-output-record.
1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 1998,1999,2000,2001 by Michael McDonald (mikemac@mikemac.com)
4 ;;; (c) copyright 2000 by
5 ;;; Robert Strandh (strandh@labri.u-bordeaux.fr)
6 ;;; (c) copyright 2001 by
7 ;;; Arnaud Rouanet (rouanet@emi.u-bordeaux.fr)
8 ;;; Lionel Salabartan (salabart@emi.u-bordeaux.fr)
9 ;;; (c) copyright 2001, 2002 by Alexey Dejneka (adejneka@comail.ru)
10
11 ;;; This library is free software; you can redistribute it and/or
12 ;;; modify it under the terms of the GNU Library General Public
13 ;;; License as published by the Free Software Foundation; either
14 ;;; version 2 of the License, or (at your option) any later version.
15 ;;;
16 ;;; This library is distributed in the hope that it will be useful,
17 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
19 ;;; Library General Public License for more details.
20 ;;;
21 ;;; You should have received a copy of the GNU Library General Public
22 ;;; License along with this library; if not, write to the
23 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 ;;; Boston, MA 02111-1307 USA.
25
26 ;;; TODO:
27 ;;;
28 ;;; - Scrolling does not work correctly. Region is given in "window"
29 ;;; coordinates, without bounding-rectangle-position transformation.
30 ;;; (Is it still valid?)
31 ;;;
32 ;;; - Redo setf*-output-record-position, extent recomputation for
33 ;;; compound records
34 ;;;
35 ;;; - When DRAWING-P is NIL, should stream cursor move?
36 ;;;
37 ;;; - :{X,Y}-OFFSET.
38 ;;;
39 ;;; - (SETF OUTPUT-RECORD-START-CURSOR-POSITION) does not affect the
40 ;;; bounding rectangle. What does it affect?
41 ;;;
42 ;;; - How should (SETF OUTPUT-RECORD-POSITION) affect the bounding
43 ;;; rectangle of the parent? Now its bounding rectangle is accurately
44 ;;; recomputed, but it is very inefficient for table formatting. It
45 ;;; seems that CLIM is supposed to keep a "large enougn" rectangle and
46 ;;; to shrink it to the correct size only when the layout is complete
47 ;;; by calling TREE-RECOMPUTE-EXTENT.
48 ;;;
49 ;;; - Computation of the bounding rectangle of lines/polygons ignores
50 ;;; LINE-STYLE-CAP-SHAPE.
51 ;;;
52 ;;; - Rounding of coordinates.
53 ;;;
54 ;;; - Document carefully the interface of
55 ;;; STANDARD-OUTPUT-RECORDING-STREAM.
56 ;;;
57 ;;; - COORD-SEQ is a sequence, not a list.
58
59 ;;; Troubles
60
61 ;;; DC
62 ;;;
63 ;;; Some GFs are defined to have "a default method on CLIM's standard
64 ;;; output record class". What does it mean? What is "CLIM's standard
65 ;;; output record class"? Is it OUTPUT-RECORD or BASIC-OUTPUT-RECORD?
66 ;;; Now they are defined on OUTPUT-RECORD.
67
68 ;;; TDO
69 ;;;
70 ;;; Text output record must save ink and clipping region. But its
71 ;;; protocol does not give any way to do it! And a user can put in a
72 ;;; history a record of any class :(. Now we are using
73 ;;; *DRAWING-OPTIONS* to put the necessary information and make sure
74 ;;; that only instances of STANDARD-TEXT-OUTPUT-RECORD are used for
75 ;;; recording. -- APD, 2002-06-15.
76
77 (in-package :CLIM-INTERNALS)
78
79 (define-protocol-class output-record (bounding-rectangle)
80 ())
81
82 (define-protocol-class displayed-output-record (output-record)
83 ())
84
85 ;;; 16.2.1. The Basic Output Record Protocol
86 #+:cmu(declaim (ftype (function (output-record) (values rational rational))
87 output-record-position))
88 (defgeneric output-record-position (record)
89 (:documentation
90 "Returns the x and y position of RECORD. The position is the
91 position of the upper-left corner of its bounding rectangle. The
92 position is relative to the stream, where (0,0) is (initially) the
93 upper-left corner of the stream."))
94
95 (defgeneric* (setf output-record-position) (x y record)
96 (:documentation
97 "Changes the x and y position of the RECORD to be X and Y, and
98 updates the bounding rectangle to reflect the new position (and saved
99 cursor positions, if the output record stores it). If RECORD has any
100 children, all of the children (and their descendants as well) will be
101 moved by the same amount as RECORD was moved. The bounding rectangles
102 of all of RECORD's ancestors will also be updated to be large enough
103 to contain RECORD."))
104
105 #+:cmu(declaim (ftype (function (output-record) (values integer integer))
106 output-record-start-cursor-position))
107 (defgeneric output-record-start-cursor-position (record)
108 (:documentation
109 "Returns the x and y starting cursor position of RECORD. The
110 positions are relative to the stream, where (0,0) is (initially) the
111 upper-left corner of the stream."))
112
113 (defgeneric* (setf output-record-start-cursor-position) (x y record))
114
115 #+:cmu(declaim (ftype (function (output-record) (values integer integer))
116 output-record-end-cursor-position))
117 (defgeneric output-record-end-cursor-position (record)
118 (:documentation
119 "Returns the x and y ending cursor position of RECORD. The
120 positions are relative to the stream, where (0,0) is (initially) the
121 upper-left corner of the stream."))
122
123 (defgeneric* (setf output-record-end-cursor-position) (x y record))
124
125 (defgeneric output-record-parent (record)
126 (:documentation
127 "Returns the output record that is the parent of RECORD, or NIL if
128 RECORD has no parent."))
129
130 (defgeneric (setf output-record-parent) (parent record)
131 (:documentation "Non-standard function."))
132
133 (defgeneric replay-output-record (record stream
134 &optional region x-offset y-offset)
135 (:documentation "Displays the output captured by RECORD on the
136 STREAM, exactly as it was originally captured. The current user
137 transformation, line style, text style, ink and clipping region of
138 STREAM are all ignored. Instead, these are gotten from the output
139 record.
140
141 Only those records that overlap REGION are displayed."))
142
143 (defgeneric output-record-hit-detection-rectangle* (record))
144
145 (defgeneric output-record-refined-position-test (record x y))
146
147 (defgeneric highlight-output-record (record stream state))
148
149 (defgeneric displayed-output-record-ink (displayed-output-record))
150
151 ;;; 16.2.2. Output Record "Database" Protocol
152
153 (defgeneric output-record-children (record))
154
155 (defgeneric add-output-record (child record))
156
157 (defgeneric delete-output-record (child record &optional errorp))
158
159 (defgeneric clear-output-record (record))
160
161 (defgeneric output-record-count (record))
162
163 (defgeneric map-over-output-records-containing-position
164 (function record x y &optional x-offset y-offset &rest function-args)
165 (:documentation "Maps over all of the children of RECORD that
166 contain the point at (X,Y), calling FUNCTION on each one. FUNCTION is
167 a function of one or more arguments, the first argument being the
168 record containing the point. FUNCTION is also called with all of
169 FUNCTION-ARGS as APPLY arguments.
170
171 If there are multiple records that contain the point,
172 MAP-OVER-OUTPUT-RECORDS-CONTAINING-POSITION hits the most recently
173 inserted record first and the least recently inserted record
174 last. Otherwise, the order in which the records are traversed is
175 unspecified."))
176
177 (defgeneric map-over-output-records-overlapping-region
178 (function record region &optional x-offset y-offset &rest function-args)
179 (:documentation "Maps over all of the children of the RECORD that
180 overlap the REGION, calling FUNCTION on each one. FUNCTION is a
181 function of one or more arguments, the first argument being the record
182 overlapping the region. FUNCTION is also called with all of
183 FUNCTION-ARGS as APPLY arguments.
184
185 If there are multiple records that overlap the region and that overlap
186 each other, MAP-OVER-OUTPUT-RECORDS-OVERLAPPING-REGION hits the least
187 recently inserted record first and the most recently inserted record
188 last. Otherwise, the order in which the records are traversed is
189 unspecified. "))
190
191 ;;; From the Franz CLIM user's guide but not in the spec... clearly necessary.
192 ;;; What is its status? -- APD, 2002-06-14.
193 (defgeneric map-over-output-records
194 (continuation record &optional x-offset y-offset &rest 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 (defgeneric invoke-with-new-output-record (stream continuation record-type
263 &rest initargs
264 &key
265 &allow-other-keys))
266
267 (defgeneric invoke-with-output-to-output-record
268 (stream continuation record-type
269 &rest initargs
270 &key
271 &allow-other-keys))
272
273 (defgeneric make-design-from-output-record (record))
274
275 ;;; 21.3 Incremental Redisplay Protocol. These generic functions need
276 ;;; to be implemented for all the basic displayed-output-records, so they are
277 ;;; defined in this file.
278
279 (defgeneric match-output-records (record &rest args))
280
281 (defgeneric match-output-records-1 (record &key)
282 (:method-combination and :most-specific-last))
283
284 ;;; Macros
285 (defmacro with-output-recording-options ((stream
286 &key (record nil record-supplied-p)
287 (draw nil draw-supplied-p))
288 &body body)
289 (when (eq stream 't) (setq stream '*standard-output*))
290 (check-type stream symbol)
291 (with-gensyms (continuation)
292 `(flet ((,continuation (,stream)
293 (declare (ignorable ,stream))
294 ,@body))
295 (declare (dynamic-extent #',continuation))
296 (invoke-with-output-recording-options
297 ,stream #',continuation
298 ,(if record-supplied-p record `(stream-recording-p ,stream))
299 ,(if draw-supplied-p draw `(stream-drawing-p ,stream))))))
300
301 (defmacro with-new-output-record ((stream
302 &optional
303 (record-type ''standard-sequence-output-record)
304 (record nil record-supplied-p)
305 &rest initargs)
306 &body body)
307 "Creates a new output record of type RECORD-TYPE and then captures
308 the output of BODY into the new output record, and inserts the new
309 record into the current \"open\" output record assotiated with STREAM.
310 If RECORD is supplied, it is the name of a variable that will be
311 lexically bound to the new output record inside the body. INITARGS are
312 CLOS initargs that are passed to MAKE-INSTANCE when the new output
313 record is created.
314 It returns the created output record.
315 The STREAM argument is a symbol that is bound to an output
316 recording stream. If it is T, *STANDARD-OUTPUT* is used."
317 (when (eq stream 't) (setq stream '*standard-output*))
318 (check-type stream symbol)
319 (unless record-supplied-p (setq record (gensym)))
320 `(invoke-with-new-output-record ,stream
321 #'(lambda (,stream ,record)
322 (declare (ignorable ,stream ,record))
323 ,@body)
324 ,record-type
325 ,@initargs))
326
327 (defmacro with-output-to-output-record
328 ((stream
329 &optional (record-type ''standard-sequence-output-record)
330 (record nil record-supplied-p)
331 &rest initargs)
332 &body body)
333 "Creates a new output record of type RECORD-TYPE and then captures
334 the output of BODY into the new output record. The cursor position of
335 STREAM is initially bound to (0,0)
336 If RECORD is supplied, it is the name of a variable that will be
337 lexically bound to the new output record inside the body. INITARGS are
338 CLOS initargs that are passed to MAKE-INSTANCE when the new output
339 record is created.
340 It returns the created output record.
341 The STREAM argument is a symbol that is bound to an output
342 recording stream. If it is T, *STANDARD-OUTPUT* is used."
343 (when (eq stream 't) (setq stream '*standard-output*))
344 (check-type stream symbol)
345 (unless record-supplied-p (setq record (gensym "RECORD")))
346 `(invoke-with-output-to-output-record
347 ,stream
348 #'(lambda (,stream ,record)
349 (declare (ignorable ,stream ,record))
350 ,@body)
351 ,record-type
352 ,@initargs))
353
354
355 ;;;; Implementation
356
357 (defclass basic-output-record (standard-bounding-rectangle output-record)
358 ((parent :initarg :parent ; XXX
359 :initform nil
360 :accessor output-record-parent)) ; XXX
361 (:documentation "Implementation class for the Basic Output Record Protocol."))
362
363 (defmethod initialize-instance :after ((record basic-output-record)
364 &rest args
365 &key (x-position 0) (y-position 0))
366 (declare (ignore args))
367 (with-slots (x1 y1 x2 y2) record
368 (setq x1 x-position
369 y1 y-position
370 x2 x-position
371 y2 y-position)))
372
373 (defclass compound-output-record (basic-output-record)
374 ((x :initarg :x-position
375 :initform 0
376 :documentation "X-position of the empty record.")
377 (y :initarg :y-position
378 :initform 0
379 :documentation "Y-position of the empty record.")
380 (in-moving-p :initform nil
381 :documentation "Is set while changing the position."))
382 (:documentation "Implementation class for output records with children."))
383
384 ;;; 16.2.1. The Basic Output Record Protocol
385 (defmethod output-record-position ((record basic-output-record))
386 (bounding-rectangle-position record))
387
388 (defmethod* (setf output-record-position) (nx ny (record basic-output-record))
389 (with-slots (x1 y1 x2 y2) record
390 (let ((dx (- nx x1))
391 (dy (- ny y1)))
392 (setf x1 nx y1 ny
393 x2 (+ x2 dx) y2 (+ y2 dy))))
394 (values nx ny))
395
396 (defmethod* (setf output-record-position) :around
397 (nx ny (record basic-output-record))
398 (with-bounding-rectangle* (min-x min-y max-x max-y) record
399 (call-next-method)
400 (let ((parent (output-record-parent record)))
401 (when parent
402 (recompute-extent-for-changed-child parent record
403 min-x min-y max-x max-y))))
404 (values nx ny))
405
406 (defmethod* (setf output-record-position) :before
407 (nx ny (record compound-output-record))
408 (with-slots (x1 y1 in-moving-p) record
409 (letf ((in-moving-p t))
410 (let ((dx (- nx x1))
411 (dy (- ny y1)))
412 (map-over-output-records
413 (lambda (child)
414 (multiple-value-bind (x y) (output-record-position child)
415 (setf (output-record-position child)
416 (values (+ x dx) (+ y dy)))))
417 record)))))
418
419 (defmethod output-record-start-cursor-position ((record basic-output-record))
420 (values nil nil))
421
422 (defmethod* (setf output-record-start-cursor-position)
423 (x y (record basic-output-record))
424 (values x y))
425
426 (defmethod output-record-end-cursor-position ((record basic-output-record))
427 (values nil nil))
428
429 (defmethod* (setf output-record-end-cursor-position)
430 (x y (record basic-output-record))
431 (values x y))
432
433 ;;; Humph. It'd be nice to tie this to the actual definition of a
434 ;;; medium. -- moore
435 (defclass complete-medium-state
436 (gs-ink-mixin gs-clip-mixin gs-line-style-mixin gs-text-style-mixin)
437 ())
438
439 (defun replay (record stream &optional region)
440 (stream-close-text-output-record stream)
441 (when (stream-drawing-p stream)
442 (with-cursor-off stream
443 (letf (((stream-cursor-position stream) (values 0 0))
444 ((stream-recording-p stream) nil)
445 ;; Is there a better value to bind to baseline?
446 ((slot-value stream 'baseline) (slot-value stream 'baseline)))
447 (with-sheet-medium (medium stream)
448 (let ((medium-state (make-instance 'complete-medium-state
449 :medium medium)))
450 (unwind-protect
451 (progn
452 (setf (medium-transformation medium)
453 +identity-transformation+)
454 (replay-output-record record stream region))
455 (set-medium-graphics-state medium-state medium))))))))
456
457
458 (defmethod replay-output-record ((record compound-output-record) stream
459 &optional region (x-offset 0) (y-offset 0))
460 (when (null region)
461 (setq region +everywhere+))
462 (map-over-output-records-overlapping-region
463 #'replay-output-record record region x-offset y-offset
464 stream region x-offset y-offset))
465
466 (defmethod output-record-hit-detection-rectangle* ((record output-record))
467 ;; XXX DC
468 (bounding-rectangle* record))
469
470 (defmethod output-record-refined-position-test ((record basic-output-record)
471 x y)
472 (declare (ignore x y))
473 t)
474
475 ;;; XXX Should this only be defined on recording streams?
476 (defmethod highlight-output-record ((record output-record)
477 stream state)
478 ;; XXX DC
479 ;; XXX Disable recording?
480 (letf (((medium-transformation stream) +identity-transformation+))
481 (multiple-value-bind (x1 y1 x2 y2)
482 (output-record-hit-detection-rectangle* record)
483 (ecase state
484 (:highlight
485 (draw-rectangle* (sheet-medium stream) x1 y1 x2 y2
486 :filled nil :ink +foreground-ink+)) ; XXX +FLIPPING-INK+?
487 (:unhighlight
488 (draw-rectangle* (sheet-medium stream) x1 y1 x2 y2
489 :filled nil :ink +background-ink+)))))) ; XXX +FLIPPING-INK+?
490
491 ;;; 16.2.2. The Output Record "Database" Protocol
492 (defmethod output-record-children ((record basic-output-record))
493 nil)
494
495 (defmethod add-output-record (child (record basic-output-record))
496 (declare (ignore child))
497 (error "Cannot add a child to ~S." record))
498
499 (defmethod add-output-record :before (child (record compound-output-record))
500 (let ((parent (output-record-parent child)))
501 (when parent
502 (restart-case
503 (error "~S already has a parent ~S." child parent)
504 (delete ()
505 :report "Delete from the old parent."
506 (delete-output-record child parent))))))
507
508 (defmethod add-output-record :after (child (record compound-output-record))
509 (recompute-extent-for-new-child record child))
510
511 (defmethod delete-output-record (child (record basic-output-record)
512 &optional (errorp t))
513 (declare (ignore child))
514 (when errorp (error "Cannot delete a child from ~S." record)))
515
516 (defmethod delete-output-record :after (child (record compound-output-record)
517 &optional (errorp t))
518 (declare (ignore errorp))
519 (with-bounding-rectangle* (x1 y1 x2 y2) child
520 (recompute-extent-for-changed-child record child x1 y1 x2 y2)))
521
522 (defmethod clear-output-record ((record basic-output-record))
523 (error "Cannot clear ~S." record))
524
525 (defmethod clear-output-record :after ((record compound-output-record))
526 (with-slots (x y x1 y1 x2 y2) record
527 (setf x1 x y1 y
528 x2 x y2 y)))
529
530 (defmethod output-record-count ((record basic-output-record))
531 0)
532
533 (defmethod map-over-output-records
534 (function (record basic-output-record)
535 &optional (x-offset 0) (y-offset 0)
536 &rest function-args)
537 (declare (ignore function x-offset y-offset function-args))
538 nil)
539
540 ;;; This needs to work in "most recently added last" order. Is this
541 ;;; implementation right? -- APD, 2002-06-13
542 #+nil
543 (defmethod map-over-output-records
544 (function (record compound-output-record)
545 &optional (x-offset 0) (y-offset 0)
546 &rest function-args)
547 (declare (ignore x-offset y-offset))
548 (map nil (lambda (child) (apply function child function-args))
549 (output-record-children record)))
550
551 (defmethod map-over-output-records-containing-position
552 (function (record basic-output-record) x y
553 &optional (x-offset 0) (y-offset 0)
554 &rest function-args)
555 (declare (ignore function x y x-offset y-offset function-args))
556 nil)
557
558 ;;; This needs to work in "most recently added first" order. Is this
559 ;;; implementation right? -- APD, 2002-06-13
560 #+nil
561 (defmethod map-over-output-records-containing-position
562 (function (record compound-output-record) x y
563 &optional (x-offset 0) (y-offset 0)
564 &rest function-args)
565 (declare (ignore x-offset y-offset))
566 (map nil
567 (lambda (child)
568 (when (and (multiple-value-bind (min-x min-y max-x max-y)
569 (output-record-hit-detection-rectangle* child)
570 (and (<= min-x x max-x) (<= min-y y max-y)))
571 (output-record-refined-position-test child x y))
572 (apply function child function-args)))
573 (output-record-children record)))
574
575 (defmethod map-over-output-records-overlapping-region
576 (function (record basic-output-record) region
577 &optional (x-offset 0) (y-offset 0)
578 &rest function-args)
579 (declare (ignore function region x-offset y-offset function-args))
580 nil)
581
582 ;;; This needs to work in "most recently added last" order. Is this
583 ;;; implementation right? -- APD, 2002-06-13
584 #+nil
585 (defmethod map-over-output-records-overlapping-region
586 (function (record compound-output-record) region
587 &optional (x-offset 0) (y-offset 0)
588 &rest function-args)
589 (declare (ignore x-offset y-offset))
590 (map nil
591 (lambda (child) (when (region-intersects-region-p region child)
592 (apply function child function-args)))
593 (output-record-children record)))
594
595 ;;; 16.2.3. Output Record Change Notification Protocol
596 (defmethod recompute-extent-for-new-child
597 ((record compound-output-record) child)
598 (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2) record
599 (with-slots (parent x1 y1 x2 y2) record
600 (if (= 1 (length (output-record-children record)))
601 (setf (values x1 y1 x2 y2) (bounding-rectangle* child))
602 (with-bounding-rectangle* (x1-child y1-child x2-child y2-child) child
603 (minf x1 x1-child)
604 (minf y1 y1-child)
605 (maxf x2 x2-child)
606 (maxf y2 y2-child)))
607 (when parent
608 (recompute-extent-for-changed-child parent record
609 old-x1 old-y1 old-x2 old-y2))))
610 record)
611
612 (defmethod %tree-recompute-extent* ((record compound-output-record))
613 ;; Internal helper function
614 (let ((new-x1 0)
615 (new-y1 0)
616 (new-x2 0)
617 (new-y2 0)
618 (first-time t))
619 (map-over-output-records
620 (lambda (child)
621 (if first-time
622 (progn
623 (multiple-value-setq (new-x1 new-y1 new-x2 new-y2)
624 (bounding-rectangle* child))
625 (setq first-time nil))
626 (with-bounding-rectangle* (cx1 cy1 cx2 cy2) child
627 (minf new-x1 cx1)
628 (minf new-y1 cy1)
629 (maxf new-x2 cx2)
630 (maxf new-y2 cy2))))
631 record)
632 (if first-time
633 (with-slots (x y) record
634 (values x y x y))
635 (values new-x1 new-y1 new-x2 new-y2))))
636
637 (defmethod recompute-extent-for-changed-child
638 ((record compound-output-record) changed-child
639 old-min-x old-min-y old-max-x old-max-y)
640 ;; If the child's old and new bbox lies entirely within the record's bbox
641 ;; then no change need be made to the record's bbox. Otherwise, if some part
642 ;; of the child's bbox was on the record's bbox and is now inside, examine
643 ;; all the children to determine the correct new bbox.
644 (with-slots (x1 y1 x2 y2) record
645 (with-bounding-rectangle* (child-x1 child-y1 child-x2 child-y2)
646 changed-child
647 (unless (and (> x1 old-min-x) (> x1 child-x1)
648 (> y1 old-min-y) (> y1 child-y1)
649 (< x2 old-max-x) (< x2 child-x2)
650 (< y2 old-max-y) (< y2 child-y2))
651 ;; Don't know if changed-child has been deleted or what, so go through
652 ;; all the children and construct the updated bbox.
653 (setf (values x1 y1 x2 y2) (%tree-recompute-extent* record)))))
654 record)
655
656 (defmethod recompute-extent-for-changed-child :around
657 ((record compound-output-record) child
658 old-min-x old-min-y old-max-x old-max-y)
659 (declare (ignore child old-min-x old-min-y old-max-x old-max-y))
660 (unless (slot-value record 'in-moving-p)
661 (let ((old-rectangle (multiple-value-call #'make-bounding-rectangle
662 (bounding-rectangle* record))))
663 (call-next-method)
664 (with-slots (parent x1 y1 x2 y2) record
665 (when (and parent (not (region-equal old-rectangle record)))
666 (multiple-value-call #'recompute-extent-for-changed-child
667 (values parent record)
668 (bounding-rectangle* old-rectangle))))))
669 record)
670
671 (defmethod tree-recompute-extent ((record compound-output-record))
672 (with-slots (x1 y1 x2 y2) record
673 (setf (values x1 y1 x2 y2) (%tree-recompute-extent* record)))
674 record)
675
676 (defmethod tree-recompute-extent :around ((record compound-output-record))
677 (let ((old-rectangle (multiple-value-call #'make-bounding-rectangle
678 (bounding-rectangle* record))))
679 (call-next-method)
680 (with-slots (parent x1 y1 x2 y2) record
681 (when (and parent (not (region-equal old-rectangle record)))
682 (recompute-extent-for-changed-child parent record x1 y1 x2 y2))))
683 record)
684
685 ;;; 16.3.1. Standard output record classes
686
687 (defclass standard-sequence-output-record (compound-output-record)
688 ((children :initform (make-array 8 :adjustable t :fill-pointer 0)
689 :reader output-record-children)))
690
691 (defmethod add-output-record (child (record standard-sequence-output-record))
692 (vector-push-extend child (output-record-children record))
693 (setf (output-record-parent child) record))
694
695 (defmethod delete-output-record (child (record standard-sequence-output-record)
696 &optional (errorp t))
697 (with-slots (children) record
698 (let ((pos (position child children :test #'eq)))
699 (if (null pos)
700 (when errorp
701 (error "~S is not a child of ~S" child record))
702 (progn
703 (setq children (replace children children
704 :start1 pos
705 :start2 (1+ pos)))
706 (decf (fill-pointer children))
707 (setf (output-record-parent child) nil))))))
708
709 (defmethod clear-output-record ((record standard-sequence-output-record))
710 (let ((children (output-record-children record)))
711 (map 'nil (lambda (child) (setf (output-record-parent child) nil))
712 children)
713 (fill children nil)
714 (setf (fill-pointer children) 0)))
715
716 (defmethod output-record-count ((record standard-sequence-output-record))
717 (length (output-record-children record)))
718
719 (defmethod map-over-output-records
720 (function (record standard-sequence-output-record)
721 &optional (x-offset 0) (y-offset 0)
722 &rest function-args)
723 "Applies FUNCTION to all children in the order they were added."
724 (declare (ignore x-offset y-offset))
725 (loop with children = (output-record-children record)
726 for child across children
727 do (apply function child function-args)))
728
729 (defmethod map-over-output-records-containing-position
730 (function (record standard-sequence-output-record) x y
731 &optional (x-offset 0) (y-offset 0)
732 &rest function-args)
733 "Applies FUNCTION to children, containing (X,Y), in the reversed
734 order they were added."
735 (declare (ignore x-offset y-offset))
736 (loop with children = (output-record-children record)
737 for i from (1- (length children)) downto 0
738 for child = (aref children i)
739 when (and (multiple-value-bind (min-x min-y max-x max-y)
740 (output-record-hit-detection-rectangle* child)
741 (and (<= min-x x max-x) (<= min-y y max-y)))
742 (output-record-refined-position-test child x y))
743 do (apply function child function-args)))
744
745 (defmethod map-over-output-records-overlapping-region
746 (function (record standard-sequence-output-record) region
747 &optional (x-offset 0) (y-offset 0)
748 &rest function-args)
749 "Applies FUNCTION to children, overlapping REGION, in the order they
750 were added."
751 (declare (ignore x-offset y-offset))
752 (loop with children = (output-record-children record)
753 for child across children
754 when (region-intersects-region-p region child)
755 do (apply function child function-args)))
756
757 ;;; XXX bogus for now.
758 (defclass standard-tree-output-record (standard-sequence-output-record)
759 (
760 ))
761
762 (defmethod match-output-records ((record t) &rest args)
763 (apply #'match-output-records-1 record args))
764
765 ;;; Factor out the graphics state portions of the output records so
766 ;;; they can be manipulated seperately e.g., by incremental
767 ;;; display. The individual slots of a graphics state are factored into mixin
768 ;;; classes so that each output record can capture only the state that it needs.
769 ;;; -- moore
770
771 ;;; It would be appealing to define a setf method, e.g. (setf
772 ;;; medium-graphics-state), for setting a medium's state from a graphics state
773 ;;; object, but that would require us to define a medium-graphics-state reader
774 ;;; that would cons a state object. I don't want to do that.
775
776 (defclass graphics-state ()
777 ()
778 (:documentation "Stores those parts of the medium/stream graphics state
779 that need to be restored when drawing an output record"))
780
781 (defgeneric set-medium-graphics-state (state medium)
782 (:documentation "Sets the MEDIUM graphics state from STATE"))
783
784 (defmethod set-medium-graphics-state (state medium)
785 (declare (ignore medium))
786 state)
787
788 (defmethod set-medium-graphics-state (state (stream output-recording-stream))
789 (with-sheet-medium (medium stream)
790 (set-medium-graphics-state state medium)))
791
792 (defclass gs-ink-mixin (graphics-state)
793 ((ink :initarg :ink :accessor graphics-state-ink)))
794
795 (defmethod initialize-instance :after ((obj gs-ink-mixin)
796 &key (stream nil)
797 (medium (when stream
798 (sheet-medium stream))))
799 (when (and medium (not (slot-boundp obj 'ink)))
800 (setf (slot-value obj 'ink) (medium-ink medium))))
801
802 (defmethod set-medium-graphics-state :after ((state gs-ink-mixin) medium)
803 (setf (medium-ink medium) (graphics-state-ink state)))
804
805 (defmethod match-output-records-1 and ((record gs-ink-mixin)
806 &key (ink nil inkp))
807 (or (null inkp)
808 (design-equalp (graphics-state-ink record) ink)))
809
810 (defclass gs-clip-mixin (graphics-state)
811 ((clip :initarg :clipping-region :accessor graphics-state-clip
812 :documentation "Clipping region in stream coordinates.")))
813
814
815 (defmethod initialize-instance :after ((obj gs-clip-mixin)
816 &key (stream nil)
817 (medium (when stream
818 (sheet-medium stream))))
819 (when medium
820 (with-slots (clip)
821 obj
822 (let ((clip-region (if (slot-boundp obj 'clip)
823 (region-intersection (medium-clipping-region
824 medium)
825 clip)
826 (medium-clipping-region medium))))
827 (setq clip (transform-region (medium-transformation medium)
828 clip-region))))))
829
830 (defmethod set-medium-graphics-state :after ((state gs-clip-mixin) medium)
831 (setf (medium-clipping-region medium) (graphics-state-clip state)))
832
833 (defmethod match-output-records-1 and ((record gs-clip-mixin)
834 &key (clip nil clipp))
835 (or clipp
836 (region-equal (graphics-state-clip record) clip)))
837
838 ;;; 16.3.2. Graphics Displayed Output Records
839 (defclass standard-displayed-output-record (gs-clip-mixin gs-ink-mixin
840 basic-output-record
841 displayed-output-record)
842 ((ink :reader displayed-output-record-ink))
843 (:documentation "Implementation class for DISPLAYED-OUTPUT-RECORD."))
844
845 (defclass gs-line-style-mixin (graphics-state)
846 ((line-style :initarg :line-style :accessor graphics-state-line-style)))
847
848 (defmethod initialize-instance :after ((obj gs-line-style-mixin)
849 &key (stream nil)
850 (medium (when stream
851 (sheet-medium stream))))
852 (when medium
853 (unless (slot-boundp obj 'line-style)
854 (setf (slot-value obj 'line-style) (medium-line-style medium)))))
855
856 (defmethod set-medium-graphics-state :after ((state gs-line-style-mixin) medium)
857 (setf (medium-line-style medium) (graphics-state-line-style state)))
858
859 (defmethod match-output-records-1 and ((record gs-line-style-mixin)
860 &key (line-style nil line-style-p))
861 (or (null line-style-p)
862 (line-style-equalp (graphics-state-line-style record) line-style)))
863
864 (defgeneric graphics-state-line-style-border (record medium)
865 (:method ((record gs-line-style-mixin) medium)
866 (/ (line-style-effective-thickness (graphics-state-line-style record)
867 medium)
868 2)))
869
870 (defclass gs-text-style-mixin (graphics-state)
871 ((text-style :initarg :text-style :accessor graphics-state-text-style)))
872
873 (defmethod initialize-instance :after ((obj gs-text-style-mixin)
874 &key (stream nil)
875 (medium (when stream
876 (sheet-medium stream))))
877 (when medium
878 (unless (slot-boundp obj 'text-style)
879 (setf (slot-value obj 'text-style) (medium-text-style medium)))))
880
881 (defmethod set-medium-graphics-state :after ((state gs-text-style-mixin) medium)
882 (setf (medium-text-style medium) (graphics-state-text-style state)))
883
884 (defmethod match-output-records-1 and ((record gs-text-style-mixin)
885 &key (text-style nil text-style-p))
886 (or (null text-style-p)
887 (text-style-equalp (graphics-state-text-style record) text-style)))
888
889 (defclass standard-graphics-displayed-output-record
890 (standard-displayed-output-record
891 graphics-displayed-output-record)
892 ())
893
894 (defmethod match-output-records-1 and
895 ((record standard-displayed-output-record)
896 &key (x1 nil x1-p) (y1 nil y1-p)
897 (x2 nil x2-p) (y2 nil y2-p)
898 (bounding-rectangle nil bounding-rectangle-p))
899 (if bounding-rectangle-p
900 (region-equal record bounding-rectangle)
901 (multiple-value-bind (my-x1 my-y1 my-x2 my-y2)
902 (bounding-rectangle* record)
903 (and (or (null x1-p) (coordinate= my-x1 x1))
904 (or (null y1-p) (coordinate= my-y1 y1))
905 (or (null x2-p) (coordinate= my-x2 x2))
906 (or (null y2-p) (coordinate= my-y2 y2))))))
907
908 ;;; This is an around method so that more specific before methods can be
909 ;;; defined for the various mixin classes, that modify the state after it has
910 ;;; been set in the graphics state.
911
912 (defmethod replay-output-record :around
913 ((record standard-displayed-output-record) stream
914 &optional region x-offset y-offset)
915 (declare (ignore region x-offset y-offset))
916 (set-medium-graphics-state record stream)
917 (call-next-method))
918
919 (defclass coord-seq-mixin ()
920 ((coord-seq :accessor coord-seq :initarg :coord-seq))
921 (:documentation "Mixin class that implements methods for records that contain
922 sequences of coordinates."))
923
924 (defun coord-seq-bounds (coord-seq border)
925 (let* ((min-x (elt coord-seq 0))
926 (min-y (elt coord-seq 1))
927 (max-x min-x)
928 (max-y min-y))
929 (do-sequence ((x y) coord-seq)
930 (minf min-x x)
931 (minf min-y y)
932 (maxf max-x x)
933 (maxf max-y y))
934 (values (- min-x border) (- min-y border)
935 (+ max-x border) (+ max-y border))))
936
937 (defmethod initialize-instance :after ((record coord-seq-mixin) &key)
938 (let ((medium (sheet-medium (slot-value record 'stream))))
939 (with-slots (coord-seq)
940 record
941 (setf coord-seq
942 (transform-position-sequence 'vector
943 (medium-transformation medium)
944 coord-seq)))))
945
946 ;;; x1, y1 slots must exist in class...
947
948 (defmethod* (setf output-record-position) :around
949 (nx ny (record coord-seq-mixin))
950 (with-slots (x1 y1)
951 record
952 (let ((dx (- nx x1))
953 (dy (- ny y1))
954 (coords (slot-value record 'coord-seq)))
955 (multiple-value-prog1
956 (call-next-method)
957 (loop for i from 0 below (length coords) by 2
958 do (progn
959 (incf (aref coords i) dx)
960 (incf (aref coords (1+ i) dy))))))))
961
962 (defmethod match-output-records-1 and ((record coord-seq-mixin)
963 &key (coord-seq nil coord-seq-p))
964 (or (null coord-seq-p)
965 (let* ((my-coord-seq (slot-value record 'coord-seq))
966 (len (length my-coord-seq)))
967 (and (eql len (length coord-seq))
968 (loop for elt1 across my-coord-seq
969 for elt2 across coord-seq
970 always (coordinate= elt1 elt2))))))
971
972 ;;; Do we need to save/restore graphics state in each call to
973 ;;; replay-output-record, or could we do it only in replay? I'd like to save
974 ;;; state in a graphics state object, but I'm not going to allocate one in each
975 ;;; recursive invocation of replay-output-record :P -- moore
976
977 (defmacro def-grecording (name ((&rest mixins) &rest args) &body body)
978 (let ((method-name (symbol-concat '#:medium- name '*))
979 (class-name (symbol-concat name '#:-OUTPUT-RECORD))
980 (medium (gensym "MEDIUM"))
981 (class-vars `((stream :initarg :stream)
982 ,@(loop for arg in args
983 collect `(,arg
984 :initarg ,(intern (symbol-name arg)
985 :keyword)))))
986 (arg-list (loop for arg in args
987 nconc `(,(intern (symbol-name arg) :keyword) ,arg))))
988 `(progn
989 (defclass ,class-name (,@mixins standard-graphics-displayed-output-record)
990 ,class-vars)
991 (defmethod initialize-instance :after ((graphic ,class-name) &rest args)
992 (declare (ignore args))
993 (with-slots (x1 y1 x2 y2
994 stream ink clipping-region
995 line-style text-style ,@args)
996 graphic
997 (let* ((medium (sheet-medium stream))
998 (border (/ (line-style-effective-thickness
999 line-style medium)
1000 2)))
1001 (declare (ignorable border))
1002 (multiple-value-setq (x1 y1 x2 y2) (progn ,@body)))))
1003 (defmethod ,method-name :around ((stream output-recording-stream) ,@args)
1004 ;; XXX STANDARD-OUTPUT-RECORDING-STREAM ^?
1005 (with-sheet-medium (medium stream)
1006 (when (stream-recording-p stream)
1007 (let ((record (make-instance ',class-name
1008 :stream stream
1009 ,@arg-list)))
1010 (stream-add-output-record stream record)))
1011 (when (stream-drawing-p stream)
1012 (call-next-method))))
1013 (defmethod replay-output-record ((record ,class-name) stream
1014 &optional (region +everywhere+)
1015 (x-offset 0) (y-offset 0))
1016 (declare (ignore x-offset y-offset region))
1017 (with-slots (,@args) record
1018 (let ((,medium (sheet-medium stream))
1019 ;; is sheet a sheet-with-medium-mixin? --GB
1020 )
1021 ;; Graphics state is set up in :around method.
1022 (,method-name ,medium ,@args)))))))
1023
1024 (def-grecording draw-point ((gs-line-style-mixin) point-x point-y)
1025 (let ((border (graphics-state-line-style-border graphic medium)))
1026 (with-transformed-position ((medium-transformation medium) point-x point-y)
1027 (setf (slot-value graphic 'point-x) point-x
1028 (slot-value graphic 'point-y) point-y)
1029 (values (- point-x border)
1030 (- point-y border)
1031 (+ point-x border)
1032 (+ point-y border)))))
1033
1034 (defmethod* (setf output-record-position) :around
1035 (nx ny (record draw-point-output-record))
1036 (with-slots (x1 y1 point-x point-y)
1037 record
1038 (let ((dx (- nx x1))
1039 (dy (- ny y1)))
1040 (multiple-value-prog1
1041 (call-next-method)
1042 (incf point-x dx)
1043 (incf point-y dy)))))
1044
1045 (defmethod match-output-records-1 and ((record draw-point-output-record)
1046 &key (point-x nil point-x-p)
1047 (point-y nil point-y-p))
1048 (and (or (null point-x-p)
1049 (coordinate= (slot-value record 'point-x) point-x))
1050 (or (null point-y-p)
1051 (coordinate= (slot-value record 'point-y) point-y))))
1052
1053
1054 (def-grecording draw-points ((coord-seq-mixin gs-line-style-mixin) coord-seq)
1055 ;; coord-seq has already been transformed
1056 (let ((border (graphics-state-line-style-border graphic medium)))
1057 (coord-seq-bounds coord-seq border)))
1058
1059 (def-grecording draw-line ((gs-line-style-mixin)
1060 point-x1 point-y1 point-x2 point-y2)
1061 (let ((transform (medium-transformation medium))
1062 (border (graphics-state-line-style-border graphic medium)))
1063 (with-transformed-position (transform point-x1 point-y1)
1064 (with-transformed-position (transform point-x2 point-y2)
1065 (setf (slot-value graphic 'point-x1) point-x1
1066 (slot-value graphic 'point-y1) point-y1
1067 (slot-value graphic 'point-x2) point-x2
1068 (slot-value graphic 'point-y2) point-y2)
1069 (values (- (min point-x1 point-x2) border)
1070 (- (min point-y1 point-y2) border)
1071 (+ (max point-x1 point-x2) border)
1072 (+ (max point-y1 point-y2) border))))))
1073
1074 (defmethod* (setf output-record-position) :around
1075 (nx ny (record draw-line-output-record))
1076 (with-slots (x1 y1
1077 point-x1 point-y1 point-x2 point-y2)
1078 record
1079 (let ((dx (- nx x1))
1080 (dy (- ny y1)))
1081 (multiple-value-prog1
1082 (call-next-method)
1083 (incf point-x1 dx)
1084 (incf point-y1 dy)
1085 (incf point-x2 dx)
1086 (incf point-y2 dy)))))
1087
1088 (defmethod match-output-records-1 and ((record draw-line-output-record)
1089 &key (point-x1 nil point-x1-p)
1090 (point-y1 nil point-y1-p)
1091 (point-x2 nil point-x2-p)
1092 (point-y2 nil point-y2-p))
1093 (and (or (null point-x1-p)
1094 (coordinate= (slot-value record 'point-x1) point-x1))
1095 (or (null point-y1-p)
1096 (coordinate= (slot-value record 'point-y1) point-y1))
1097 (or (null point-x2-p)
1098 (coordinate= (slot-value record 'point-x2) point-x2))
1099 (or (null point-y2-p)
1100 (coordinate= (slot-value record 'point-y2) point-y2))))
1101
1102
1103 (def-grecording draw-lines ((coord-seq-mixin gs-line-style-mixin) coord-seq)
1104 (let ((border (graphics-state-line-style-border graphic medium)))
1105 (coord-seq-bounds coord-seq border)))
1106
1107 ;;; Helper function
1108 (defun normalize-coords (dx dy &optional unit)
1109 (let ((norm (sqrt (+ (* dx dx) (* dy dy)))))
1110 (if unit
1111 (let ((scale (/ unit norm)))
1112 (values (* dx scale) (* dy scale)))
1113 (values (/ dx norm) (/ dy norm)))))
1114
1115 (defun polygon-record-bounding-rectangle
1116 (coord-seq closed filled line-style border miter-limit)
1117 (cond (filled
1118 (coord-seq-bounds coord-seq 0))
1119 ((eq (line-style-joint-shape line-style) :round)
1120 (coord-seq-bounds coord-seq border))
1121 (t (let* ((x1 (svref coord-seq 0))
1122 (y1 (svref coord-seq 1))
1123 (min-x x1)
1124 (min-y y1)
1125 (max-x x1)
1126 (max-y y1)
1127 (len (length coord-seq)))
1128 (unless closed
1129 (setq min-x (- x1 border) min-y (- y1 border)
1130 max-x (+ x1 border) max-y (+ y1 border)))
1131 ;; Setup for iterating over the coordinate vector. If the polygon
1132 ;; is closed deal with the extra segment.
1133 (multiple-value-bind (initial-xp initial-yp
1134 final-xn final-yn
1135 initial-index final-index)
1136 (if closed
1137 (values (svref coord-seq (- len 2))
1138 (svref coord-seq (- len 1))
1139 x1 y1
1140 0 (- len 2))
1141 (values x1 y1
1142 (svref coord-seq (- len 2))
1143 (svref coord-seq (- len 1))
1144 2 (- len 4)))
1145 (ecase (line-style-joint-shape line-style)
1146 (:miter
1147 ;;FIXME: Remove successive positively proportional segments
1148 (loop with sin-limit = (sin (* 0.5 miter-limit))
1149 and xn and yn
1150 for i from initial-index to final-index by 2
1151 for xp = initial-xp then x
1152 for yp = initial-yp then y
1153 for x = (svref coord-seq i)
1154 for y = (svref coord-seq (1+ i))
1155 do (setf (values xn yn)
1156 (if (eql i final-index)
1157 (values final-xn final-yn)
1158 (values (svref coord-seq (+ i 2))
1159 (svref coord-seq (+ i
1160 3)))))
1161 (multiple-value-bind (ex1 ey1)
1162 (normalize-coords (- x xp) (- y yp))
1163 (multiple-value-bind (ex2 ey2)
1164 (normalize-coords (- x xn) (- y yn))
1165 (let* ((cos-a (+ (* ex1 ex2) (* ey1 ey2)))
1166 (sin-a/2 (sqrt (* 0.5 (- 1.0 cos-a)))))
1167 (if (< sin-a/2 sin-limit)
1168 (let ((nx (* border
1169 (max (abs ey1) (abs ey2))))
1170 (ny (* border
1171 (max (abs ex1) (abs ex2)))))
1172 (minf min-x (- x nx))
1173 (minf min-y (- y ny))
1174 (maxf max-x (+ x nx))
1175 (maxf max-y (+ y ny)))
1176 (let ((length (/ border sin-a/2)))
1177 (multiple-value-bind (dx dy)
1178 (normalize-coords (+ ex1 ex2)
1179 (+ ey1 ey2)
1180 length)
1181 (minf min-x (+ x dx))
1182 (minf min-y (+ y dy))
1183 (maxf max-x (+ x dx))
1184 (maxf max-y (+ y dy))))))))))
1185 ((:bevel :none)
1186 (loop with xn and yn
1187 for i from initial-index to final-index by 2
1188 for xp = initial-xp then x
1189 for yp = initial-yp then y
1190 for x = (svref coord-seq i)
1191 for y = (svref coord-seq (1+ i))
1192 do (setf (values xn yn)
1193 (if (eql i final-index)
1194 (values final-xn final-yn)
1195 (values (svref coord-seq (+ i 2))
1196 (svref coord-seq (+ i
1197 3)))))
1198 (multiple-value-bind (ex1 ey1)
1199 (normalize-coords (- x xp) (- y yp))
1200 (multiple-value-bind (ex2 ey2)
1201 (normalize-coords (- x xn) (- y yn))
1202 (let ((nx (* border (max (abs ey1) (abs ey2))))
1203 (ny (* border (max (abs ex1) (abs ex2)))))
1204 (minf min-x (- x nx))
1205 (minf min-y (- y ny))
1206 (maxf max-x (+ x nx))
1207 (maxf max-y (+ y ny))))))))
1208 (unless closed
1209 (multiple-value-bind (x y)
1210 (values (svref coord-seq final-index)
1211 (svref coord-seq (1+ final-index)))
1212 (minf min-x (- x border))
1213 (minf min-y (- y border))
1214 (maxf max-x (+ x border))
1215 (maxf max-y (+ y border)))))
1216 (values min-x min-y max-x max-y)))))
1217
1218 (def-grecording draw-polygon ((coord-seq-mixin gs-line-style-mixin)
1219 coord-seq closed filled)
1220 (let ((border (graphics-state-line-style-border graphic medium)))
1221 (polygon-record-bounding-rectangle
1222 coord-seq closed filled line-style border (medium-miter-limit medium))))
1223
1224 (defmethod match-output-records-1 and ((record draw-polygon-output-record)
1225 &key (closed nil closedp)
1226 (filled nil filledp))
1227 (and (or (null closedp)
1228 (eql (slot-value record 'closed) closed))
1229 (or (null filledp)
1230 (eql (slot-value record 'filled) filled))))
1231
1232 (def-grecording draw-rectangle ((gs-line-style-mixin)
1233 left top right bottom filled)
1234 (let ((border (graphics-state-line-style-border graphic medium)))
1235 (polygon-record-bounding-rectangle
1236 (vector left top left bottom right bottom right top)
1237 t filled line-style border
1238 (medium-miter-limit medium))))
1239
1240 (defmethod* (setf output-record-position) :around
1241 (nx ny (record draw-rectangle-output-record))
1242 (with-slots (x1 y1
1243 left top right bottom)
1244 record
1245 (let ((dx (- nx x1))
1246 (dy (- ny y1)))
1247 (multiple-value-prog1
1248 (call-next-method)
1249 (incf left dx)
1250 (incf top dy)
1251 (incf right dx)
1252 (incf bottom dy)))))
1253
1254 (defmethod match-output-records-1 and ((record draw-rectangle-output-record)
1255 &key (left nil leftp)
1256 (top nil topp)
1257 (right nil rightp)
1258 (bottom nil bottomp)
1259 (filled nil filledp))
1260 (and (or (null leftp)
1261 (coordinate= (slot-value record 'left) left))
1262 (or (null topp)
1263 (coordinate= (slot-value record 'top) top))
1264 (or (null rightp)
1265 (coordinate= (slot-value record 'right) right))
1266 (or (null bottomp)
1267 (coordinate= (slot-value record 'bottom) bottom))
1268 (or (null filledp)
1269 (eql (slot-value record 'filled) filled))))
1270
1271 (def-grecording draw-ellipse ((gs-line-style-mixin)
1272 center-x center-y
1273 radius-1-dx radius-1-dy radius-2-dx radius-2-dy
1274 start-angle end-angle filled)
1275 (multiple-value-bind (min-x min-y max-x max-y)
1276 (bounding-rectangle* (make-ellipse* center-x center-y
1277 radius-1-dx radius-1-dy
1278 radius-2-dx radius-2-dy
1279 :start-angle start-angle
1280 :end-angle end-angle))
1281 (if filled
1282 (values min-x min-y max-x max-y)
1283 (let ((border (graphics-state-line-style-border graphic medium)))
1284 (values (- min-x border)
1285 (- min-y border)
1286 (+ max-x border)
1287 (+ max-y border))))))
1288
1289 (defmethod* (setf output-record-position) :around
1290 (nx ny (record draw-ellipse-output-record))
1291 (with-slots (x1 y1 center-x center-y)
1292 record
1293 (let ((dx (- nx x1))
1294 (dy (- ny y1)))
1295 (multiple-value-prog1
1296 (call-next-method)
1297 (incf center-x dx)
1298 (incf center-y dy)))))
1299
1300 (defmethod match-output-records-1 and ((record draw-ellipse-output-record)
1301 &key (center-x nil center-x-p)
1302 (center-y nil center-y-p))
1303 (and (or (null center-x-p)
1304 (coordinate= (slot-value record 'center-x) center-x))
1305 (or (null center-y-p)
1306 (coordinate= (slot-value record 'center-y) center-y))))
1307
1308 (def-grecording draw-text ((gs-text-style-mixin) string point-x point-y start end
1309 align-x align-y toward-x toward-y transform-glyphs)
1310 ;; FIXME!!! Text direction.
1311 ;; Multiple lines?
1312 (let* ((text-style (graphics-state-text-style graphic))
1313 (width (stream-string-width stream string
1314 :start start :end end
1315 :text-style text-style))
1316 (ascent (text-style-ascent text-style (sheet-medium stream)))
1317 (descent (text-style-descent text-style (sheet-medium stream)))
1318 (height (+ ascent descent))
1319 left top right bottom)
1320 (ecase align-x
1321 (:left (setq left point-x
1322 right (+ point-x width)))
1323 (:right (setq left (- point-x width)
1324 right point-x))
1325 (:center (setq left (- point-x (round width 2))
1326 right (+ point-x (round width 2)))))
1327 (ecase align-y
1328 (:baseline (setq top (- point-y ascent)
1329 bottom (+ point-y descent)))
1330 (:top (setq top point-y
1331 bottom (+ point-y height)))
1332 (:bottom (setq top (- point-y height)
1333 bottom point-y))
1334 (:center (setq top (- point-y (floor height 2))
1335 bottom (+ point-y (ceiling height 2)))))
1336 (values left top right bottom)))
1337
1338 (defmethod* (setf output-record-position) :around
1339 (nx ny (record draw-text-output-record))
1340 (with-slots (x1 y1 point-x point-y toward-x toward-y)
1341 record
1342 (let ((dx (- nx x1))
1343 (dy (- ny y1)))
1344 (multiple-value-prog1
1345 (call-next-method)
1346 (incf point-x dx)
1347 (incf point-y dy)
1348 (incf toward-x dx)
1349 (incf toward-y dy)))))
1350
1351 (defmethod match-output-records-1 and ((record draw-text-output-record)
1352 &key (string nil stringp)
1353 (start nil startp)
1354 (end nil endp)
1355 (point-x nil point-x-p)
1356 (point-y nil point-y-p)
1357 (align-x nil align-x-p)
1358 (align-y nil align-y-p)
1359 (toward-x nil toward-x-p)
1360 (toward-y nil toward-y-p)
1361 (transform-glyphs nil
1362 transform-glyphs-p))
1363 (and (or (null stringp)
1364 (string= (slot-value record 'string) string))
1365 (or (null startp)
1366 (eql (slot-value record 'start) start))
1367 (or (null endp)
1368 (eql (slot-value record 'end) end))
1369 (or (null point-x-p)
1370 (coordinate= (slot-value record 'point-x) point-x))
1371 (or (null point-y-p)
1372 (coordinate= (slot-value record 'point-y) point-y))
1373 (or (null align-x-p)
1374 (eq (slot-value record 'align-x) align-x))
1375 (or (null align-y-p)
1376 (eq (slot-value record 'align-y) align-y))
1377 (or (null toward-x-p)
1378 (coordinate= (slot-value record 'toward-x) toward-x))
1379 (or (null toward-y-p)
1380 (coordinate= (slot-value record 'toward-y) toward-y))
1381 (or (null transform-glyphs-p)
1382 (eq (slot-value record 'transform-glyphs) transform-glyphs))))
1383
1384 ;;; 16.3.3. Text Displayed Output Record
1385 (defvar *drawing-options* (list +foreground-ink+ +everywhere+)
1386 "The ink and the clipping region of the current stream.") ; XXX TDO
1387
1388 (defclass styled-string (gs-text-style-mixin gs-clip-mixin gs-ink-mixin)
1389 ((start-x :initarg :start-x)
1390 (string :initarg :string :reader styled-string-string)))
1391
1392 (defclass standard-text-displayed-output-record
1393 (text-displayed-output-record standard-displayed-output-record)
1394 ((initial-x1 :initarg :start-x)
1395 (initial-y1 :initarg :start-y)
1396 (strings :initform nil)
1397 (baseline :initform 0)
1398 (width :initform 0)
1399 (max-height :initform 0)
1400 (start-x :initarg :start-x)
1401 (start-y :initarg :start-y)
1402 (end-x :initarg :start-x)
1403 (end-y :initarg :start-y)
1404 (wrapped :initform nil
1405 :accessor text-record-wrapped)
1406 (medium :initarg :medium :initform nil)))
1407
1408 (defmethod initialize-instance :after
1409 ((obj standard-text-displayed-output-record) &key stream)
1410 (when stream
1411 (setf (slot-value obj 'medium) (sheet-medium stream))))
1412
1413 (defmethod print-object ((self standard-text-displayed-output-record) stream)
1414 (print-unreadable-object (self stream :type t :identity t)
1415 (with-slots (start-x start-y strings) self
1416 (format stream "~D,~D ~S"
1417 start-x start-y
1418 (mapcar #'styled-string-string strings)))))
1419
1420 (defmethod* (setf output-record-position) :before
1421 (nx ny (record standard-text-displayed-output-record))
1422 (with-slots (x1 y1 start-x start-y end-x end-y strings) record
1423 (let ((dx (- nx x1))
1424 (dy (- ny y1)))
1425 (incf start-x dx)
1426 (incf start-y dy)
1427 (incf end-x dx)
1428 (incf end-y dy)
1429 (loop for s in strings
1430 do (incf (slot-value s 'start-x) dx)))))
1431
1432 (defmethod replay-output-record ((record standard-text-displayed-output-record)
1433 stream
1434 &optional region (x-offset 0) (y-offset 0))
1435 (declare (ignore region x-offset y-offset))
1436 (with-slots (strings baseline max-height start-y wrapped x1 y1)
1437 record
1438 (with-sheet-medium (medium stream) ;is sheet a sheet-with-medium-mixin? --GB
1439 ;; FIXME:
1440 ;; 1. SLOT-VALUE...
1441 ;; 2. It should also save a "current line".
1442 (setf (slot-value stream 'baseline) baseline)
1443 (loop for substring in strings
1444 do (with-slots (start-x string)
1445 substring
1446 (setf (stream-cursor-position stream)
1447 (values start-x start-y))
1448 (set-medium-graphics-state substring medium)
1449 (stream-write-line stream string)))
1450 (when wrapped ; FIXME
1451 (draw-rectangle* medium
1452 (+ wrapped 0) start-y
1453 (+ wrapped 4) (+ start-y max-height)
1454 :ink +foreground-ink+
1455 :filled t)))))
1456
1457 (defmethod output-record-start-cursor-position
1458 ((record standard-text-displayed-output-record))
1459 (with-slots (start-x start-y) record
1460 (values start-x start-y)))
1461
1462 (defmethod output-record-end-cursor-position
1463 ((record standard-text-displayed-output-record))
1464 (with-slots (end-x end-y) record
1465 (values end-x end-y)))
1466
1467 (defmethod tree-recompute-extent
1468 ((text-record standard-text-displayed-output-record))
1469 (with-slots (parent x1 y1 x2 y2 width max-height) text-record
1470 (setq x2 (coordinate (+ x1 width))
1471 y2 (coordinate (+ y1 max-height))))
1472 text-record)
1473
1474 (defmethod add-character-output-to-text-record ; XXX OAOO with ADD-STRING-...
1475 ((text-record standard-text-displayed-output-record)
1476 character text-style char-width height new-baseline)
1477 (with-slots (strings baseline width max-height start-y end-x end-y medium)
1478 text-record
1479 (if (and strings
1480 (let ((string (last1 strings)))
1481 (match-output-records string
1482 :text-style text-style
1483 :ink (medium-ink medium)
1484 :clipping-region (medium-clipping-region
1485 medium))))
1486 (vector-push-extend character (slot-value (last1 strings) 'string))
1487 (nconcf strings
1488 (list (make-instance
1489 'styled-string
1490 :start-x end-x
1491 :text-style text-style
1492 :medium medium ; pick up ink and clipping region
1493 :string (make-array 1 :initial-element character
1494 :element-type 'character
1495 :adjustable t
1496 :fill-pointer t)))))
1497 (setq baseline (max baseline new-baseline)
1498 end-x (+ end-x char-width)
1499 max-height (max max-height height)
1500 end-y (max end-y (+ start-y max-height))
1501 width (+ width char-width)))
1502 (tree-recompute-extent text-record))
1503
1504 (defmethod add-string-output-to-text-record
1505 ((text-record standard-text-displayed-output-record)
1506 string start end text-style string-width height new-baseline)
1507 (if end
1508 (setq end (min end (length string)))
1509 (setq end (length string)))
1510 (let ((length (max 0 (- end start))))
1511 (cond
1512 ((eql length 1)
1513 (add-character-output-to-text-record text-record
1514 (aref string start)
1515 text-style
1516 string-width height new-baseline))
1517 (t (with-slots (strings baseline width max-height start-y end-x end-y
1518 medium)
1519 text-record
1520 (let ((styled-string (make-instance
1521 'styled-string
1522 :start-x end-x
1523 :text-style text-style
1524 :medium medium
1525 :string (make-array (length string)
1526 :element-type 'character
1527 :adjustable t
1528 :fill-pointer t))))
1529 (nconcf strings (list styled-string))
1530 (replace (styled-string-string styled-string) string
1531 :start2 start :end2 end))
1532 (setq baseline (max baseline new-baseline)
1533 end-x (+ end-x string-width)
1534 max-height (max max-height height)
1535 end-y (max end-y (+ start-y max-height))
1536 width (+ width string-width)))
1537 (tree-recompute-extent text-record)))))
1538
1539 (defmethod text-displayed-output-record-string
1540 ((record standard-text-displayed-output-record))
1541 (with-output-to-string (result)
1542 (with-slots (strings) record
1543 (loop for (nil nil substring) in strings
1544 do (write-string substring result)))))
1545
1546 ;;; 16.3.4. Top-Level Output Records
1547 (defclass stream-output-history-mixin ()
1548 ())
1549
1550 (defclass standard-sequence-output-history
1551 (standard-sequence-output-record stream-output-history-mixin)
1552 ())
1553
1554 (defclass standard-tree-output-history
1555 (standard-tree-output-record stream-output-history-mixin)
1556 ())
1557
1558 ;;; 16.4. Output Recording Streams
1559 (defclass standard-output-recording-stream (output-recording-stream)
1560 ((recording-p :initform t :reader stream-recording-p)
1561 (drawing-p :initform t :accessor stream-drawing-p)
1562 (output-history :initform (make-instance 'standard-tree-output-history)
1563 :reader stream-output-history)
1564 (current-output-record :accessor stream-current-output-record)
1565 (current-text-output-record :initform nil
1566 :accessor stream-current-text-output-record)
1567 (local-record-p :initform t
1568 :documentation "This flag is used for dealing with streams outputting strings char-by-char.")))
1569
1570 (defmethod initialize-instance :after
1571 ((stream standard-output-recording-stream) &rest args)
1572 (declare (ignore args))
1573 (setf (stream-current-output-record stream) (stream-output-history stream)))
1574
1575 ;;; Used in initializing clim-stream-pane
1576
1577 (defmethod reset-output-history ((stream
1578 standard-output-recording-stream))
1579 (setf (slot-value stream 'output-history)
1580 (make-instance 'standard-tree-output-history))
1581 (setf (stream-current-output-record stream) (stream-output-history stream)))
1582
1583 ;;; 16.4.1 The Output Recording Stream Protocol
1584 (defmethod (setf stream-recording-p)
1585 (recording-p (stream standard-output-recording-stream))
1586 (let ((old-val (slot-value stream 'recording-p)))
1587 (setf (slot-value stream 'recording-p) recording-p)
1588 (when (not (eq old-val recording-p))
1589 (stream-close-text-output-record stream))
1590 recording-p))
1591
1592 (defmethod stream-add-output-record
1593 ((stream standard-output-recording-stream) record)
1594 (add-output-record record (stream-current-output-record stream)))
1595
1596 (defmethod stream-replay
1597 ((stream standard-output-recording-stream) &optional region)
1598 (replay (stream-output-history stream) stream region))
1599
1600 (defun output-record-ancestor-p (ancestor child)
1601 (loop for record = child then parent
1602 for parent = (output-record-parent record)
1603 when (eq parent nil) do (return nil)
1604 when (eq parent ancestor) do (return t)))
1605
1606 (defmethod erase-output-record (record (stream standard-output-recording-stream)
1607 &optional (errorp t))
1608 (letf (((stream-recording-p stream) nil))
1609 (let ((region (bounding-rectangle record)))
1610 (with-bounding-rectangle* (x1 y1 x2 y2) region
1611 (if (output-record-ancestor-p (stream-output-history stream) record)
1612 (progn
1613 (delete-output-record record (output-record-parent record))
1614 (with-output-recording-options (stream :record nil)
1615 (draw-rectangle* stream x1 y1 x2 y2 :ink +background-ink+))
1616 (stream-replay stream region))
1617 (when errorp
1618 (error "~S is not contained in ~S." record stream)))))))
1619
1620 (defun copy-textual-output-history (window stream &optional region record)
1621 ;; FIXME
1622 (declare (ignore window stream region record))
1623 (error "Not implemented."))
1624
1625 ;;; 16.4.3. Text Output Recording
1626 (defmethod stream-text-output-record
1627 ((stream standard-output-recording-stream) text-style)
1628 (declare (ignore text-style))
1629 (let ((record (stream-current-text-output-record stream)))
1630 (unless (and record (typep record 'standard-text-displayed-output-record))
1631 (multiple-value-bind (cx cy) (stream-cursor-position stream)
1632 (setf record (make-instance 'standard-text-displayed-output-record
1633 :x-position cx :y-position cy
1634 :start-x cx :start-y cy
1635 :stream stream)
1636 (stream-current-text-output-record stream) record)))
1637 record))
1638
1639 (defmethod stream-close-text-output-record
1640 ((stream standard-output-recording-stream))
1641 (let ((record (stream-current-text-output-record stream)))
1642 (when record
1643 (setf (stream-current-text-output-record stream) nil)
1644 #|record stream-current-cursor-position to (end-x record) - already done|#
1645 (stream-add-output-record stream record))))
1646
1647 (defmethod stream-add-character-output
1648 ((stream standard-output-recording-stream)
1649 character text-style width height baseline)
1650 (add-character-output-to-text-record
1651 (stream-text-output-record stream text-style)
1652 character text-style width height baseline))
1653
1654 (defmethod stream-add-string-output ((stream standard-output-recording-stream)
1655 string start end text-style
1656 width height baseline)
1657 (add-string-output-to-text-record (stream-text-output-record stream
1658 text-style)
1659 string start end text-style
1660 width height baseline))
1661
1662 ;;; Text output catching methods
1663 (defmacro without-local-recording (stream &body body)
1664 `(letf (((slot-value ,stream 'local-record-p) nil))
1665 ,@body))
1666
1667 (defmethod stream-write-line :around
1668 ((stream standard-output-recording-stream) line)
1669 (when (and (stream-recording-p stream)
1670 (slot-value stream 'local-record-p))
1671 (let* ((medium (sheet-medium stream))
1672 (text-style (medium-text-style medium))
1673 (*drawing-options* (list (medium-ink medium) ; XXX TDO
1674 (medium-clipping-region medium))))
1675 (stream-add-string-output stream line 0 nil text-style
1676 (stream-string-width stream line
1677 :text-style text-style)
1678 (text-style-height text-style medium)
1679 (text-style-ascent text-style medium))))
1680 (when (stream-drawing-p stream)
1681 (without-local-recording stream
1682 (call-next-method))))
1683
1684 #+nil
1685 (defmethod stream-write-char :around ((stream standard-output-recording-stream) char)
1686 (when (and (stream-recording-p stream)
1687 (slot-value stream 'local-record-p))
1688 (if (or (eql char #\return)
1689
1690 (stream-close-text-output-record stream)
1691 (let* ((medium (sheet-medium stream))
1692 (text-style (medium-text-style medium)))
1693 (stream-add-character-output stream char text-style
1694 (stream-character-width stream char :text-style text-style)
1695 (text-style-height text-style medium)
1696 (text-style-ascent text-style medium)))))
1697 (without-local-recording stream
1698 (call-next-method))))
1699
1700 #+nil
1701 (defmethod stream-write-string :around ((stream standard-output-recording-stream) string
1702 &optional (start 0) end)
1703 ;; Problem: it is necessary to check for line wrapping. Now the
1704 ;; default method for STREAM-WRITE-STRING do char-by-char output,
1705 ;; therefore STREAM-WRITE-CHAR can do the right thing.
1706 (when (and (stream-recording-p stream)
1707 (slot-value stream 'local-record-p))
1708 (let* ((medium (sheet-medium stream))
1709 (text-style (medium-text-style medium)))
1710 (stream-add-string-output stream string start end text-style
1711 (stream-string-width stream string
1712 :start start :end end
1713 :text-style text-style)
1714 (text-style-height text-style medium)
1715 (text-style-ascent text-style medium))))
1716 (without-local-recording stream
1717 (call-next-method)))
1718
1719
1720 (defmethod stream-finish-output :after ((stream standard-output-recording-stream))
1721 (stream-close-text-output-record stream))
1722
1723 (defmethod stream-force-output :after ((stream standard-output-recording-stream))
1724 (stream-close-text-output-record stream))
1725
1726 (defmethod stream-terpri :after ((stream standard-output-recording-stream))
1727 (stream-close-text-output-record stream))
1728
1729 (defmethod* (setf stream-cursor-position) :after (x y (stream standard-output-recording-stream))
1730 (declare (ignore x y))
1731 (stream-close-text-output-record stream))
1732
1733 ;(defmethod stream-set-cursor-position :after ((stream standard-output-recording-stream))
1734 ; (stream-close-text-output-record stream))
1735
1736 (defmethod stream-wrap-line :before ((stream standard-output-recording-stream))
1737 (when (stream-recording-p stream)
1738 (setf (text-record-wrapped (stream-text-output-record stream nil)) ; FIXME!
1739 (stream-text-margin stream))))
1740
1741 ;;; 16.4.4. Output Recording Utilities
1742
1743 (defmethod invoke-with-output-recording-options
1744 ((stream output-recording-stream) continuation record draw)
1745 "Calls CONTINUATION on STREAM enabling or disabling recording and drawing
1746 according to the flags RECORD and DRAW."
1747 (letf (((stream-recording-p stream) record)
1748 ((stream-drawing-p stream) draw))
1749 (funcall continuation stream)))
1750
1751 (defmethod invoke-with-new-output-record ((stream output-recording-stream)
1752 continuation record-type
1753 &rest initargs
1754 &key
1755 &allow-other-keys)
1756 (stream-close-text-output-record stream)
1757 (let ((new-record (apply #'make-instance record-type initargs)))
1758 (letf (((stream-current-output-record stream) new-record))
1759 ;; Should we switch on recording? -- APD
1760 (funcall continuation stream new-record)
1761 (finish-output stream))
1762 (stream-add-output-record stream new-record)
1763 new-record))
1764
1765 (defmethod invoke-with-output-to-output-record
1766 ((stream output-recording-stream) continuation record-type
1767 &rest initargs
1768 &key
1769 &allow-other-keys)
1770 (stream-close-text-output-record stream)
1771 (let ((new-record (apply #'make-instance record-type initargs)))
1772 (with-output-recording-options (stream :record t :draw nil)
1773 (letf (((stream-current-output-record stream) new-record)
1774 ((stream-cursor-position stream) (values 0 0)))
1775 (funcall continuation stream new-record)
1776 (finish-output stream)))
1777 new-record))
1778
1779 (defmethod make-design-from-output-record (record)
1780 ;; FIXME
1781 (declare (ignore record))
1782 (error "Not implemented."))
1783
1784
1785 ;;; Additional methods
1786 (defmethod scroll-vertical :around ((stream output-recording-stream) dy)
1787 (declare (ignore dy))
1788 (with-output-recording-options (stream :record nil)
1789 (call-next-method)))
1790
1791 (defmethod scroll-horizontal :around ((stream output-recording-stream) dx)
1792 (declare (ignore dx))
1793 (with-output-recording-options (stream :record nil)
1794 (call-next-method)))
1795
1796 (defmethod handle-repaint ((stream output-recording-stream) region)
1797 (stream-replay stream region))
1798

  ViewVC Help
Powered by ViewVC 1.1.5