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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.58 - (show annotations)
Thu Mar 13 06:55:27 2003 UTC (11 years, 1 month ago) by strandh
Branch: MAIN
Changes since 1.57: +1 -5 lines
Removed border calculation from the :after method of initialize instance for
output records.  That calculation used a line style not always present in
the output record.  Verified that no @body uses this border calculation.
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 (multiple-value-setq (x1 y1 x2 y2) (progn ,@body)))))
999 (defmethod ,method-name :around ((stream output-recording-stream) ,@args)
1000 ;; XXX STANDARD-OUTPUT-RECORDING-STREAM ^?
1001 (with-sheet-medium (medium stream)
1002 (when (stream-recording-p stream)
1003 (let ((record (make-instance ',class-name
1004 :stream stream
1005 ,@arg-list)))
1006 (stream-add-output-record stream record)))
1007 (when (stream-drawing-p stream)
1008 (call-next-method))))
1009 (defmethod replay-output-record ((record ,class-name) stream
1010 &optional (region +everywhere+)
1011 (x-offset 0) (y-offset 0))
1012 (declare (ignore x-offset y-offset region))
1013 (with-slots (,@args) record
1014 (let ((,medium (sheet-medium stream))
1015 ;; is sheet a sheet-with-medium-mixin? --GB
1016 )
1017 ;; Graphics state is set up in :around method.
1018 (,method-name ,medium ,@args)))))))
1019
1020 (def-grecording draw-point ((gs-line-style-mixin) point-x point-y)
1021 (let ((border (graphics-state-line-style-border graphic medium)))
1022 (with-transformed-position ((medium-transformation medium) point-x point-y)
1023 (setf (slot-value graphic 'point-x) point-x
1024 (slot-value graphic 'point-y) point-y)
1025 (values (- point-x border)
1026 (- point-y border)
1027 (+ point-x border)
1028 (+ point-y border)))))
1029
1030 (defmethod* (setf output-record-position) :around
1031 (nx ny (record draw-point-output-record))
1032 (with-slots (x1 y1 point-x point-y)
1033 record
1034 (let ((dx (- nx x1))
1035 (dy (- ny y1)))
1036 (multiple-value-prog1
1037 (call-next-method)
1038 (incf point-x dx)
1039 (incf point-y dy)))))
1040
1041 (defmethod match-output-records-1 and ((record draw-point-output-record)
1042 &key (point-x nil point-x-p)
1043 (point-y nil point-y-p))
1044 (and (or (null point-x-p)
1045 (coordinate= (slot-value record 'point-x) point-x))
1046 (or (null point-y-p)
1047 (coordinate= (slot-value record 'point-y) point-y))))
1048
1049
1050 (def-grecording draw-points ((coord-seq-mixin gs-line-style-mixin) coord-seq)
1051 ;; coord-seq has already been transformed
1052 (let ((border (graphics-state-line-style-border graphic medium)))
1053 (coord-seq-bounds coord-seq border)))
1054
1055 (def-grecording draw-line ((gs-line-style-mixin)
1056 point-x1 point-y1 point-x2 point-y2)
1057 (let ((transform (medium-transformation medium))
1058 (border (graphics-state-line-style-border graphic medium)))
1059 (with-transformed-position (transform point-x1 point-y1)
1060 (with-transformed-position (transform point-x2 point-y2)
1061 (setf (slot-value graphic 'point-x1) point-x1
1062 (slot-value graphic 'point-y1) point-y1
1063 (slot-value graphic 'point-x2) point-x2
1064 (slot-value graphic 'point-y2) point-y2)
1065 (values (- (min point-x1 point-x2) border)
1066 (- (min point-y1 point-y2) border)
1067 (+ (max point-x1 point-x2) border)
1068 (+ (max point-y1 point-y2) border))))))
1069
1070 (defmethod* (setf output-record-position) :around
1071 (nx ny (record draw-line-output-record))
1072 (with-slots (x1 y1
1073 point-x1 point-y1 point-x2 point-y2)
1074 record
1075 (let ((dx (- nx x1))
1076 (dy (- ny y1)))
1077 (multiple-value-prog1
1078 (call-next-method)
1079 (incf point-x1 dx)
1080 (incf point-y1 dy)
1081 (incf point-x2 dx)
1082 (incf point-y2 dy)))))
1083
1084 (defmethod match-output-records-1 and ((record draw-line-output-record)
1085 &key (point-x1 nil point-x1-p)
1086 (point-y1 nil point-y1-p)
1087 (point-x2 nil point-x2-p)
1088 (point-y2 nil point-y2-p))
1089 (and (or (null point-x1-p)
1090 (coordinate= (slot-value record 'point-x1) point-x1))
1091 (or (null point-y1-p)
1092 (coordinate= (slot-value record 'point-y1) point-y1))
1093 (or (null point-x2-p)
1094 (coordinate= (slot-value record 'point-x2) point-x2))
1095 (or (null point-y2-p)
1096 (coordinate= (slot-value record 'point-y2) point-y2))))
1097
1098
1099 (def-grecording draw-lines ((coord-seq-mixin gs-line-style-mixin) coord-seq)
1100 (let ((border (graphics-state-line-style-border graphic medium)))
1101 (coord-seq-bounds coord-seq border)))
1102
1103 ;;; Helper function
1104 (defun normalize-coords (dx dy &optional unit)
1105 (let ((norm (sqrt (+ (* dx dx) (* dy dy)))))
1106 (if unit
1107 (let ((scale (/ unit norm)))
1108 (values (* dx scale) (* dy scale)))
1109 (values (/ dx norm) (/ dy norm)))))
1110
1111 (defun polygon-record-bounding-rectangle
1112 (coord-seq closed filled line-style border miter-limit)
1113 (cond (filled
1114 (coord-seq-bounds coord-seq 0))
1115 ((eq (line-style-joint-shape line-style) :round)
1116 (coord-seq-bounds coord-seq border))
1117 (t (let* ((x1 (svref coord-seq 0))
1118 (y1 (svref coord-seq 1))
1119 (min-x x1)
1120 (min-y y1)
1121 (max-x x1)
1122 (max-y y1)
1123 (len (length coord-seq)))
1124 (unless closed
1125 (setq min-x (- x1 border) min-y (- y1 border)
1126 max-x (+ x1 border) max-y (+ y1 border)))
1127 ;; Setup for iterating over the coordinate vector. If the polygon
1128 ;; is closed deal with the extra segment.
1129 (multiple-value-bind (initial-xp initial-yp
1130 final-xn final-yn
1131 initial-index final-index)
1132 (if closed
1133 (values (svref coord-seq (- len 2))
1134 (svref coord-seq (- len 1))
1135 x1 y1
1136 0 (- len 2))
1137 (values x1 y1
1138 (svref coord-seq (- len 2))
1139 (svref coord-seq (- len 1))
1140 2 (- len 4)))
1141 (ecase (line-style-joint-shape line-style)
1142 (:miter
1143 ;;FIXME: Remove successive positively proportional segments
1144 (loop with sin-limit = (sin (* 0.5 miter-limit))
1145 and xn and yn
1146 for i from initial-index to final-index by 2
1147 for xp = initial-xp then x
1148 for yp = initial-yp then y
1149 for x = (svref coord-seq i)
1150 for y = (svref coord-seq (1+ i))
1151 do (setf (values xn yn)
1152 (if (eql i final-index)
1153 (values final-xn final-yn)
1154 (values (svref coord-seq (+ i 2))
1155 (svref coord-seq (+ i
1156 3)))))
1157 (multiple-value-bind (ex1 ey1)
1158 (normalize-coords (- x xp) (- y yp))
1159 (multiple-value-bind (ex2 ey2)
1160 (normalize-coords (- x xn) (- y yn))
1161 (let* ((cos-a (+ (* ex1 ex2) (* ey1 ey2)))
1162 (sin-a/2 (sqrt (* 0.5 (- 1.0 cos-a)))))
1163 (if (< sin-a/2 sin-limit)
1164 (let ((nx (* border
1165 (max (abs ey1) (abs ey2))))
1166 (ny (* border
1167 (max (abs ex1) (abs ex2)))))
1168 (minf min-x (- x nx))
1169 (minf min-y (- y ny))
1170 (maxf max-x (+ x nx))
1171 (maxf max-y (+ y ny)))
1172 (let ((length (/ border sin-a/2)))
1173 (multiple-value-bind (dx dy)
1174 (normalize-coords (+ ex1 ex2)
1175 (+ ey1 ey2)
1176 length)
1177 (minf min-x (+ x dx))
1178 (minf min-y (+ y dy))
1179 (maxf max-x (+ x dx))
1180 (maxf max-y (+ y dy))))))))))
1181 ((:bevel :none)
1182 (loop with xn and yn
1183 for i from initial-index to final-index by 2
1184 for xp = initial-xp then x
1185 for yp = initial-yp then y
1186 for x = (svref coord-seq i)
1187 for y = (svref coord-seq (1+ i))
1188 do (setf (values xn yn)
1189 (if (eql i final-index)
1190 (values final-xn final-yn)
1191 (values (svref coord-seq (+ i 2))
1192 (svref coord-seq (+ i
1193 3)))))
1194 (multiple-value-bind (ex1 ey1)
1195 (normalize-coords (- x xp) (- y yp))
1196 (multiple-value-bind (ex2 ey2)
1197 (normalize-coords (- x xn) (- y yn))
1198 (let ((nx (* border (max (abs ey1) (abs ey2))))
1199 (ny (* border (max (abs ex1) (abs ex2)))))
1200 (minf min-x (- x nx))
1201 (minf min-y (- y ny))
1202 (maxf max-x (+ x nx))
1203 (maxf max-y (+ y ny))))))))
1204 (unless closed
1205 (multiple-value-bind (x y)
1206 (values (svref coord-seq final-index)
1207 (svref coord-seq (1+ final-index)))
1208 (minf min-x (- x border))
1209 (minf min-y (- y border))
1210 (maxf max-x (+ x border))
1211 (maxf max-y (+ y border)))))
1212 (values min-x min-y max-x max-y)))))
1213
1214 (def-grecording draw-polygon ((coord-seq-mixin gs-line-style-mixin)
1215 coord-seq closed filled)
1216 (let ((border (graphics-state-line-style-border graphic medium)))
1217 (polygon-record-bounding-rectangle
1218 coord-seq closed filled line-style border (medium-miter-limit medium))))
1219
1220 (defmethod match-output-records-1 and ((record draw-polygon-output-record)
1221 &key (closed nil closedp)
1222 (filled nil filledp))
1223 (and (or (null closedp)
1224 (eql (slot-value record 'closed) closed))
1225 (or (null filledp)
1226 (eql (slot-value record 'filled) filled))))
1227
1228 (def-grecording draw-rectangle ((gs-line-style-mixin)
1229 left top right bottom filled)
1230 (let ((border (graphics-state-line-style-border graphic medium)))
1231 (polygon-record-bounding-rectangle
1232 (vector left top left bottom right bottom right top)
1233 t filled line-style border
1234 (medium-miter-limit medium))))
1235
1236 (defmethod* (setf output-record-position) :around
1237 (nx ny (record draw-rectangle-output-record))
1238 (with-slots (x1 y1
1239 left top right bottom)
1240 record
1241 (let ((dx (- nx x1))
1242 (dy (- ny y1)))
1243 (multiple-value-prog1
1244 (call-next-method)
1245 (incf left dx)
1246 (incf top dy)
1247 (incf right dx)
1248 (incf bottom dy)))))
1249
1250 (defmethod match-output-records-1 and ((record draw-rectangle-output-record)
1251 &key (left nil leftp)
1252 (top nil topp)
1253 (right nil rightp)
1254 (bottom nil bottomp)
1255 (filled nil filledp))
1256 (and (or (null leftp)
1257 (coordinate= (slot-value record 'left) left))
1258 (or (null topp)
1259 (coordinate= (slot-value record 'top) top))
1260 (or (null rightp)
1261 (coordinate= (slot-value record 'right) right))
1262 (or (null bottomp)
1263 (coordinate= (slot-value record 'bottom) bottom))
1264 (or (null filledp)
1265 (eql (slot-value record 'filled) filled))))
1266
1267 (def-grecording draw-ellipse ((gs-line-style-mixin)
1268 center-x center-y
1269 radius-1-dx radius-1-dy radius-2-dx radius-2-dy
1270 start-angle end-angle filled)
1271 (multiple-value-bind (min-x min-y max-x max-y)
1272 (bounding-rectangle* (make-ellipse* center-x center-y
1273 radius-1-dx radius-1-dy
1274 radius-2-dx radius-2-dy
1275 :start-angle start-angle
1276 :end-angle end-angle))
1277 (if filled
1278 (values min-x min-y max-x max-y)
1279 (let ((border (graphics-state-line-style-border graphic medium)))
1280 (values (- min-x border)
1281 (- min-y border)
1282 (+ max-x border)
1283 (+ max-y border))))))
1284
1285 (defmethod* (setf output-record-position) :around
1286 (nx ny (record draw-ellipse-output-record))
1287 (with-slots (x1 y1 center-x center-y)
1288 record
1289 (let ((dx (- nx x1))
1290 (dy (- ny y1)))
1291 (multiple-value-prog1
1292 (call-next-method)
1293 (incf center-x dx)
1294 (incf center-y dy)))))
1295
1296 (defmethod match-output-records-1 and ((record draw-ellipse-output-record)
1297 &key (center-x nil center-x-p)
1298 (center-y nil center-y-p))
1299 (and (or (null center-x-p)
1300 (coordinate= (slot-value record 'center-x) center-x))
1301 (or (null center-y-p)
1302 (coordinate= (slot-value record 'center-y) center-y))))
1303
1304 (def-grecording draw-text ((gs-text-style-mixin) string point-x point-y start end
1305 align-x align-y toward-x toward-y transform-glyphs)
1306 ;; FIXME!!! Text direction.
1307 ;; Multiple lines?
1308 (let* ((text-style (graphics-state-text-style graphic))
1309 (width (stream-string-width stream string
1310 :start start :end end
1311 :text-style text-style))
1312 (ascent (text-style-ascent text-style (sheet-medium stream)))
1313 (descent (text-style-descent text-style (sheet-medium stream)))
1314 (height (+ ascent descent))
1315 left top right bottom)
1316 (ecase align-x
1317 (:left (setq left point-x
1318 right (+ point-x width)))
1319 (:right (setq left (- point-x width)
1320 right point-x))
1321 (:center (setq left (- point-x (round width 2))
1322 right (+ point-x (round width 2)))))
1323 (ecase align-y
1324 (:baseline (setq top (- point-y ascent)
1325 bottom (+ point-y descent)))
1326 (:top (setq top point-y
1327 bottom (+ point-y height)))
1328 (:bottom (setq top (- point-y height)
1329 bottom point-y))
1330 (:center (setq top (- point-y (floor height 2))
1331 bottom (+ point-y (ceiling height 2)))))
1332 (values left top right bottom)))
1333
1334 (defmethod* (setf output-record-position) :around
1335 (nx ny (record draw-text-output-record))
1336 (with-slots (x1 y1 point-x point-y toward-x toward-y)
1337 record
1338 (let ((dx (- nx x1))
1339 (dy (- ny y1)))
1340 (multiple-value-prog1
1341 (call-next-method)
1342 (incf point-x dx)
1343 (incf point-y dy)
1344 (incf toward-x dx)
1345 (incf toward-y dy)))))
1346
1347 (defmethod match-output-records-1 and ((record draw-text-output-record)
1348 &key (string nil stringp)
1349 (start nil startp)
1350 (end nil endp)
1351 (point-x nil point-x-p)
1352 (point-y nil point-y-p)
1353 (align-x nil align-x-p)
1354 (align-y nil align-y-p)
1355 (toward-x nil toward-x-p)
1356 (toward-y nil toward-y-p)
1357 (transform-glyphs nil
1358 transform-glyphs-p))
1359 (and (or (null stringp)
1360 (string= (slot-value record 'string) string))
1361 (or (null startp)
1362 (eql (slot-value record 'start) start))
1363 (or (null endp)
1364 (eql (slot-value record 'end) end))
1365 (or (null point-x-p)
1366 (coordinate= (slot-value record 'point-x) point-x))
1367 (or (null point-y-p)
1368 (coordinate= (slot-value record 'point-y) point-y))
1369 (or (null align-x-p)
1370 (eq (slot-value record 'align-x) align-x))
1371 (or (null align-y-p)
1372 (eq (slot-value record 'align-y) align-y))
1373 (or (null toward-x-p)
1374 (coordinate= (slot-value record 'toward-x) toward-x))
1375 (or (null toward-y-p)
1376 (coordinate= (slot-value record 'toward-y) toward-y))
1377 (or (null transform-glyphs-p)
1378 (eq (slot-value record 'transform-glyphs) transform-glyphs))))
1379
1380 ;;; 16.3.3. Text Displayed Output Record
1381 (defvar *drawing-options* (list +foreground-ink+ +everywhere+)
1382 "The ink and the clipping region of the current stream.") ; XXX TDO
1383
1384 (defclass styled-string (gs-text-style-mixin gs-clip-mixin gs-ink-mixin)
1385 ((start-x :initarg :start-x)
1386 (string :initarg :string :reader styled-string-string)))
1387
1388 (defclass standard-text-displayed-output-record
1389 (text-displayed-output-record standard-displayed-output-record)
1390 ((initial-x1 :initarg :start-x)
1391 (initial-y1 :initarg :start-y)
1392 (strings :initform nil)
1393 (baseline :initform 0)
1394 (width :initform 0)
1395 (max-height :initform 0)
1396 (start-x :initarg :start-x)
1397 (start-y :initarg :start-y)
1398 (end-x :initarg :start-x)
1399 (end-y :initarg :start-y)
1400 (wrapped :initform nil
1401 :accessor text-record-wrapped)
1402 (medium :initarg :medium :initform nil)))
1403
1404 (defmethod initialize-instance :after
1405 ((obj standard-text-displayed-output-record) &key stream)
1406 (when stream
1407 (setf (slot-value obj 'medium) (sheet-medium stream))))
1408
1409 (defmethod print-object ((self standard-text-displayed-output-record) stream)
1410 (print-unreadable-object (self stream :type t :identity t)
1411 (with-slots (start-x start-y strings) self
1412 (format stream "~D,~D ~S"
1413 start-x start-y
1414 (mapcar #'styled-string-string strings)))))
1415
1416 (defmethod* (setf output-record-position) :before
1417 (nx ny (record standard-text-displayed-output-record))
1418 (with-slots (x1 y1 start-x start-y end-x end-y strings) record
1419 (let ((dx (- nx x1))
1420 (dy (- ny y1)))
1421 (incf start-x dx)
1422 (incf start-y dy)
1423 (incf end-x dx)
1424 (incf end-y dy)
1425 (loop for s in strings
1426 do (incf (slot-value s 'start-x) dx)))))
1427
1428 (defmethod replay-output-record ((record standard-text-displayed-output-record)
1429 stream
1430 &optional region (x-offset 0) (y-offset 0))
1431 (declare (ignore region x-offset y-offset))
1432 (with-slots (strings baseline max-height start-y wrapped x1 y1)
1433 record
1434 (with-sheet-medium (medium stream) ;is sheet a sheet-with-medium-mixin? --GB
1435 ;; FIXME:
1436 ;; 1. SLOT-VALUE...
1437 ;; 2. It should also save a "current line".
1438 (setf (slot-value stream 'baseline) baseline)
1439 (loop for substring in strings
1440 do (with-slots (start-x string)
1441 substring
1442 (setf (stream-cursor-position stream)
1443 (values start-x start-y))
1444 (set-medium-graphics-state substring medium)
1445 (stream-write-line stream string)))
1446 (when wrapped ; FIXME
1447 (draw-rectangle* medium
1448 (+ wrapped 0) start-y
1449 (+ wrapped 4) (+ start-y max-height)
1450 :ink +foreground-ink+
1451 :filled t)))))
1452
1453 (defmethod output-record-start-cursor-position
1454 ((record standard-text-displayed-output-record))
1455 (with-slots (start-x start-y) record
1456 (values start-x start-y)))
1457
1458 (defmethod output-record-end-cursor-position
1459 ((record standard-text-displayed-output-record))
1460 (with-slots (end-x end-y) record
1461 (values end-x end-y)))
1462
1463 (defmethod tree-recompute-extent
1464 ((text-record standard-text-displayed-output-record))
1465 (with-slots (parent x1 y1 x2 y2 width max-height) text-record
1466 (setq x2 (coordinate (+ x1 width))
1467 y2 (coordinate (+ y1 max-height))))
1468 text-record)
1469
1470 (defmethod add-character-output-to-text-record ; XXX OAOO with ADD-STRING-...
1471 ((text-record standard-text-displayed-output-record)
1472 character text-style char-width height new-baseline)
1473 (with-slots (strings baseline width max-height start-y end-x end-y medium)
1474 text-record
1475 (if (and strings
1476 (let ((string (last1 strings)))
1477 (match-output-records string
1478 :text-style text-style
1479 :ink (medium-ink medium)
1480 :clipping-region (medium-clipping-region
1481 medium))))
1482 (vector-push-extend character (slot-value (last1 strings) 'string))
1483 (nconcf strings
1484 (list (make-instance
1485 'styled-string
1486 :start-x end-x
1487 :text-style text-style
1488 :medium medium ; pick up ink and clipping region
1489 :string (make-array 1 :initial-element character
1490 :element-type 'character
1491 :adjustable t
1492 :fill-pointer t)))))
1493 (setq baseline (max baseline new-baseline)
1494 end-x (+ end-x char-width)
1495 max-height (max max-height height)
1496 end-y (max end-y (+ start-y max-height))
1497 width (+ width char-width)))
1498 (tree-recompute-extent text-record))
1499
1500 (defmethod add-string-output-to-text-record
1501 ((text-record standard-text-displayed-output-record)
1502 string start end text-style string-width height new-baseline)
1503 (if end
1504 (setq end (min end (length string)))
1505 (setq end (length string)))
1506 (let ((length (max 0 (- end start))))
1507 (cond
1508 ((eql length 1)
1509 (add-character-output-to-text-record text-record
1510 (aref string start)
1511 text-style
1512 string-width height new-baseline))
1513 (t (with-slots (strings baseline width max-height start-y end-x end-y
1514 medium)
1515 text-record
1516 (let ((styled-string (make-instance
1517 'styled-string
1518 :start-x end-x
1519 :text-style text-style
1520 :medium medium
1521 :string (make-array (length string)
1522 :element-type 'character
1523 :adjustable t
1524 :fill-pointer t))))
1525 (nconcf strings (list styled-string))
1526 (replace (styled-string-string styled-string) string
1527 :start2 start :end2 end))
1528 (setq baseline (max baseline new-baseline)
1529 end-x (+ end-x string-width)
1530 max-height (max max-height height)
1531 end-y (max end-y (+ start-y max-height))
1532 width (+ width string-width)))
1533 (tree-recompute-extent text-record)))))
1534
1535 (defmethod text-displayed-output-record-string
1536 ((record standard-text-displayed-output-record))
1537 (with-output-to-string (result)
1538 (with-slots (strings) record
1539 (loop for (nil nil substring) in strings
1540 do (write-string substring result)))))
1541
1542 ;;; 16.3.4. Top-Level Output Records
1543 (defclass stream-output-history-mixin ()
1544 ())
1545
1546 (defclass standard-sequence-output-history
1547 (standard-sequence-output-record stream-output-history-mixin)
1548 ())
1549
1550 (defclass standard-tree-output-history
1551 (standard-tree-output-record stream-output-history-mixin)
1552 ())
1553
1554 ;;; 16.4. Output Recording Streams
1555 (defclass standard-output-recording-stream (output-recording-stream)
1556 ((recording-p :initform t :reader stream-recording-p)
1557 (drawing-p :initform t :accessor stream-drawing-p)
1558 (output-history :initform (make-instance 'standard-tree-output-history)
1559 :reader stream-output-history)
1560 (current-output-record :accessor stream-current-output-record)
1561 (current-text-output-record :initform nil
1562 :accessor stream-current-text-output-record)
1563 (local-record-p :initform t
1564 :documentation "This flag is used for dealing with streams outputting strings char-by-char.")))
1565
1566 (defmethod initialize-instance :after
1567 ((stream standard-output-recording-stream) &rest args)
1568 (declare (ignore args))
1569 (setf (stream-current-output-record stream) (stream-output-history stream)))
1570
1571 ;;; Used in initializing clim-stream-pane
1572
1573 (defmethod reset-output-history ((stream
1574 standard-output-recording-stream))
1575 (setf (slot-value stream 'output-history)
1576 (make-instance 'standard-tree-output-history))
1577 (setf (stream-current-output-record stream) (stream-output-history stream)))
1578
1579 ;;; 16.4.1 The Output Recording Stream Protocol
1580 (defmethod (setf stream-recording-p)
1581 (recording-p (stream standard-output-recording-stream))
1582 (let ((old-val (slot-value stream 'recording-p)))
1583 (setf (slot-value stream 'recording-p) recording-p)
1584 (when (not (eq old-val recording-p))
1585 (stream-close-text-output-record stream))
1586 recording-p))
1587
1588 (defmethod stream-add-output-record
1589 ((stream standard-output-recording-stream) record)
1590 (add-output-record record (stream-current-output-record stream)))
1591
1592 (defmethod stream-replay
1593 ((stream standard-output-recording-stream) &optional region)
1594 (replay (stream-output-history stream) stream region))
1595
1596 (defun output-record-ancestor-p (ancestor child)
1597 (loop for record = child then parent
1598 for parent = (output-record-parent record)
1599 when (eq parent nil) do (return nil)
1600 when (eq parent ancestor) do (return t)))
1601
1602 (defmethod erase-output-record (record (stream standard-output-recording-stream)
1603 &optional (errorp t))
1604 (letf (((stream-recording-p stream) nil))
1605 (let ((region (bounding-rectangle record)))
1606 (with-bounding-rectangle* (x1 y1 x2 y2) region
1607 (if (output-record-ancestor-p (stream-output-history stream) record)
1608 (progn
1609 (delete-output-record record (output-record-parent record))
1610 (with-output-recording-options (stream :record nil)
1611 (draw-rectangle* stream x1 y1 x2 y2 :ink +background-ink+))
1612 (stream-replay stream region))
1613 (when errorp
1614 (error "~S is not contained in ~S." record stream)))))))
1615
1616 (defun copy-textual-output-history (window stream &optional region record)
1617 ;; FIXME
1618 (declare (ignore window stream region record))
1619 (error "Not implemented."))
1620
1621 ;;; 16.4.3. Text Output Recording
1622 (defmethod stream-text-output-record
1623 ((stream standard-output-recording-stream) text-style)
1624 (declare (ignore text-style))
1625 (let ((record (stream-current-text-output-record stream)))
1626 (unless (and record (typep record 'standard-text-displayed-output-record))
1627 (multiple-value-bind (cx cy) (stream-cursor-position stream)
1628 (setf record (make-instance 'standard-text-displayed-output-record
1629 :x-position cx :y-position cy
1630 :start-x cx :start-y cy
1631 :stream stream)
1632 (stream-current-text-output-record stream) record)))
1633 record))
1634
1635 (defmethod stream-close-text-output-record
1636 ((stream standard-output-recording-stream))
1637 (let ((record (stream-current-text-output-record stream)))
1638 (when record
1639 (setf (stream-current-text-output-record stream) nil)
1640 #|record stream-current-cursor-position to (end-x record) - already done|#
1641 (stream-add-output-record stream record))))
1642
1643 (defmethod stream-add-character-output
1644 ((stream standard-output-recording-stream)
1645 character text-style width height baseline)
1646 (add-character-output-to-text-record
1647 (stream-text-output-record stream text-style)
1648 character text-style width height baseline))
1649
1650 (defmethod stream-add-string-output ((stream standard-output-recording-stream)
1651 string start end text-style
1652 width height baseline)
1653 (add-string-output-to-text-record (stream-text-output-record stream
1654 text-style)
1655 string start end text-style
1656 width height baseline))
1657
1658 ;;; Text output catching methods
1659 (defmacro without-local-recording (stream &body body)
1660 `(letf (((slot-value ,stream 'local-record-p) nil))
1661 ,@body))
1662
1663 (defmethod stream-write-line :around
1664 ((stream standard-output-recording-stream) line)
1665 (when (and (stream-recording-p stream)
1666 (slot-value stream 'local-record-p))
1667 (let* ((medium (sheet-medium stream))
1668 (text-style (medium-text-style medium))
1669 (*drawing-options* (list (medium-ink medium) ; XXX TDO
1670 (medium-clipping-region medium))))
1671 (stream-add-string-output stream line 0 nil text-style
1672 (stream-string-width stream line
1673 :text-style text-style)
1674 (text-style-height text-style medium)
1675 (text-style-ascent text-style medium))))
1676 (when (stream-drawing-p stream)
1677 (without-local-recording stream
1678 (call-next-method))))
1679
1680 #+nil
1681 (defmethod stream-write-char :around ((stream standard-output-recording-stream) char)
1682 (when (and (stream-recording-p stream)
1683 (slot-value stream 'local-record-p))
1684 (if (or (eql char #\return)
1685
1686 (stream-close-text-output-record stream)
1687 (let* ((medium (sheet-medium stream))
1688 (text-style (medium-text-style medium)))
1689 (stream-add-character-output stream char text-style
1690 (stream-character-width stream char :text-style text-style)
1691 (text-style-height text-style medium)
1692 (text-style-ascent text-style medium)))))
1693 (without-local-recording stream
1694 (call-next-method))))
1695
1696 #+nil
1697 (defmethod stream-write-string :around ((stream standard-output-recording-stream) string
1698 &optional (start 0) end)
1699 ;; Problem: it is necessary to check for line wrapping. Now the
1700 ;; default method for STREAM-WRITE-STRING do char-by-char output,
1701 ;; therefore STREAM-WRITE-CHAR can do the right thing.
1702 (when (and (stream-recording-p stream)
1703 (slot-value stream 'local-record-p))
1704 (let* ((medium (sheet-medium stream))
1705 (text-style (medium-text-style medium)))
1706 (stream-add-string-output stream string start end text-style
1707 (stream-string-width stream string
1708 :start start :end end
1709 :text-style text-style)
1710 (text-style-height text-style medium)
1711 (text-style-ascent text-style medium))))
1712 (without-local-recording stream
1713 (call-next-method)))
1714
1715
1716 (defmethod stream-finish-output :after ((stream standard-output-recording-stream))
1717 (stream-close-text-output-record stream))
1718
1719 (defmethod stream-force-output :after ((stream standard-output-recording-stream))
1720 (stream-close-text-output-record stream))
1721
1722 (defmethod stream-terpri :after ((stream standard-output-recording-stream))
1723 (stream-close-text-output-record stream))
1724
1725 (defmethod* (setf stream-cursor-position) :after (x y (stream standard-output-recording-stream))
1726 (declare (ignore x y))
1727 (stream-close-text-output-record stream))
1728
1729 ;(defmethod stream-set-cursor-position :after ((stream standard-output-recording-stream))
1730 ; (stream-close-text-output-record stream))
1731
1732 (defmethod stream-wrap-line :before ((stream standard-output-recording-stream))
1733 (when (stream-recording-p stream)
1734 (setf (text-record-wrapped (stream-text-output-record stream nil)) ; FIXME!
1735 (stream-text-margin stream))))
1736
1737 ;;; 16.4.4. Output Recording Utilities
1738
1739 (defmethod invoke-with-output-recording-options
1740 ((stream output-recording-stream) continuation record draw)
1741 "Calls CONTINUATION on STREAM enabling or disabling recording and drawing
1742 according to the flags RECORD and DRAW."
1743 (letf (((stream-recording-p stream) record)
1744 ((stream-drawing-p stream) draw))
1745 (funcall continuation stream)))
1746
1747 (defmethod invoke-with-new-output-record ((stream output-recording-stream)
1748 continuation record-type
1749 &rest initargs
1750 &key
1751 &allow-other-keys)
1752 (stream-close-text-output-record stream)
1753 (let ((new-record (apply #'make-instance record-type initargs)))
1754 (letf (((stream-current-output-record stream) new-record))
1755 ;; Should we switch on recording? -- APD
1756 (funcall continuation stream new-record)
1757 (finish-output stream))
1758 (stream-add-output-record stream new-record)
1759 new-record))
1760
1761 (defmethod invoke-with-output-to-output-record
1762 ((stream output-recording-stream) continuation record-type
1763 &rest initargs
1764 &key
1765 &allow-other-keys)
1766 (stream-close-text-output-record stream)
1767 (let ((new-record (apply #'make-instance record-type initargs)))
1768 (with-output-recording-options (stream :record t :draw nil)
1769 (letf (((stream-current-output-record stream) new-record)
1770 ((stream-cursor-position stream) (values 0 0)))
1771 (funcall continuation stream new-record)
1772 (finish-output stream)))
1773 new-record))
1774
1775 (defmethod make-design-from-output-record (record)
1776 ;; FIXME
1777 (declare (ignore record))
1778 (error "Not implemented."))
1779
1780
1781 ;;; Additional methods
1782 (defmethod scroll-vertical :around ((stream output-recording-stream) dy)
1783 (declare (ignore dy))
1784 (with-output-recording-options (stream :record nil)
1785 (call-next-method)))
1786
1787 (defmethod scroll-horizontal :around ((stream output-recording-stream) dx)
1788 (declare (ignore dx))
1789 (with-output-recording-options (stream :record nil)
1790 (call-next-method)))
1791
1792 (defmethod handle-repaint ((stream output-recording-stream) region)
1793 (stream-replay stream region))
1794

  ViewVC Help
Powered by ViewVC 1.1.5