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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5