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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5