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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5