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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.89 - (show annotations)
Wed Sep 3 12:05:59 2003 UTC (10 years, 7 months ago) by hefner1
Branch: MAIN
Changes since 1.88: +5 -4 lines
In DEF-GRECORDING, call TRANSFORM-POSITIONS on the coord-seq.
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 we morph a possible
1131 ;; coord-seq argument into a vector.
1132 (let (,@(when (member 'coord-seq args)
1133 (list `(coord-seq
1134 (transform-positions (medium-transformation medium)
1135 (if (vectorp coord-seq)
1136 coord-seq
1137 (coerce coord-seq 'vector)))))))
1138 (make-instance ',class-name
1139 :stream stream
1140 ,@arg-list))))
1141 (stream-add-output-record stream record)))
1142 (when (stream-drawing-p stream)
1143 (,method-name medium ,@args))))
1144 (defmethod replay-output-record ((record ,class-name) stream
1145 &optional (region +everywhere+)
1146 (x-offset 0) (y-offset 0))
1147 (declare (ignore x-offset y-offset region))
1148 (with-slots (,@args) record
1149 (let ((,medium (sheet-medium stream))
1150 ;; is sheet a sheet-with-medium-mixin? --GB
1151 )
1152 ;; Graphics state is set up in :around method.
1153 (,method-name ,medium ,@args)))))))
1154
1155 (def-grecording draw-point ((gs-line-style-mixin) point-x point-y)
1156 (let ((border (graphics-state-line-style-border graphic medium)))
1157 (with-transformed-position ((medium-transformation medium) point-x point-y)
1158 (setf (slot-value graphic 'point-x) point-x
1159 (slot-value graphic 'point-y) point-y)
1160 (values (- point-x border)
1161 (- point-y border)
1162 (+ point-x border)
1163 (+ point-y border)))))
1164
1165 (defmethod* (setf output-record-position) :around
1166 (nx ny (record draw-point-output-record))
1167 (with-slots (x1 y1 point-x point-y)
1168 record
1169 (let ((dx (- nx x1))
1170 (dy (- ny y1)))
1171 (multiple-value-prog1
1172 (call-next-method)
1173 (incf point-x dx)
1174 (incf point-y dy)))))
1175
1176 (defrecord-predicate draw-point-output-record (point-x point-y)
1177 (and (if-supplied (point-x coordinate)
1178 (coordinate= (slot-value record 'point-x) point-x))
1179 (if-supplied (point-y coordinate)
1180 (coordinate= (slot-value record 'point-y) point-y))))
1181
1182 (def-grecording draw-points ((coord-seq-mixin gs-line-style-mixin) coord-seq)
1183 ;; coord-seq has already been transformed
1184 (let ((border (graphics-state-line-style-border graphic medium)))
1185 (coord-seq-bounds coord-seq border)))
1186
1187 (def-grecording draw-line ((gs-line-style-mixin)
1188 point-x1 point-y1 point-x2 point-y2)
1189 (let ((transform (medium-transformation medium))
1190 (border (graphics-state-line-style-border graphic medium)))
1191 (with-transformed-position (transform point-x1 point-y1)
1192 (with-transformed-position (transform point-x2 point-y2)
1193 (setf (slot-value graphic 'point-x1) point-x1
1194 (slot-value graphic 'point-y1) point-y1
1195 (slot-value graphic 'point-x2) point-x2
1196 (slot-value graphic 'point-y2) point-y2)
1197 (values (- (min point-x1 point-x2) border)
1198 (- (min point-y1 point-y2) border)
1199 (+ (max point-x1 point-x2) border)
1200 (+ (max point-y1 point-y2) border))))))
1201
1202 (defmethod* (setf output-record-position) :around
1203 (nx ny (record draw-line-output-record))
1204 (with-slots (x1 y1
1205 point-x1 point-y1 point-x2 point-y2)
1206 record
1207 (let ((dx (- nx x1))
1208 (dy (- ny y1)))
1209 (multiple-value-prog1
1210 (call-next-method)
1211 (incf point-x1 dx)
1212 (incf point-y1 dy)
1213 (incf point-x2 dx)
1214 (incf point-y2 dy)))))
1215
1216 (defrecord-predicate draw-line-output-record (point-x1 point-y1
1217 point-x2 point-y2)
1218 (and (if-supplied (point-x1 coordinate)
1219 (coordinate= (slot-value record 'point-x1) point-x1))
1220 (if-supplied (point-y1 coordinate)
1221 (coordinate= (slot-value record 'point-y1) point-y1))
1222 (if-supplied (point-x2 coordinate)
1223 (coordinate= (slot-value record 'point-x2) point-x2))
1224 (if-supplied (point-y2 coordinate)
1225 (coordinate= (slot-value record 'point-y2) point-y2))))
1226
1227 (def-grecording draw-lines ((coord-seq-mixin gs-line-style-mixin) coord-seq)
1228 (let ((border (graphics-state-line-style-border graphic medium)))
1229 (coord-seq-bounds coord-seq border)))
1230
1231 ;;; (setf output-record-position) and predicates for draw-lines-output-record
1232 ;;; are taken care of by methods on superclasses.
1233
1234 ;;; Helper function
1235 (defun normalize-coords (dx dy &optional unit)
1236 (let ((norm (sqrt (+ (* dx dx) (* dy dy)))))
1237 (if unit
1238 (let ((scale (/ unit norm)))
1239 (values (* dx scale) (* dy scale)))
1240 (values (/ dx norm) (/ dy norm)))))
1241
1242 (defun polygon-record-bounding-rectangle
1243 (coord-seq closed filled line-style border miter-limit)
1244 (cond (filled
1245 (coord-seq-bounds coord-seq 0))
1246 ((eq (line-style-joint-shape line-style) :round)
1247 (coord-seq-bounds coord-seq border))
1248 (t (let* ((x1 (svref coord-seq 0))
1249 (y1 (svref coord-seq 1))
1250 (min-x x1)
1251 (min-y y1)
1252 (max-x x1)
1253 (max-y y1)
1254 (len (length coord-seq)))
1255 (unless closed
1256 (setq min-x (- x1 border) min-y (- y1 border)
1257 max-x (+ x1 border) max-y (+ y1 border)))
1258 ;; Setup for iterating over the coordinate vector. If the polygon
1259 ;; is closed deal with the extra segment.
1260 (multiple-value-bind (initial-xp initial-yp
1261 final-xn final-yn
1262 initial-index final-index)
1263 (if closed
1264 (values (svref coord-seq (- len 2))
1265 (svref coord-seq (- len 1))
1266 x1 y1
1267 0 (- len 2))
1268 (values x1 y1
1269 (svref coord-seq (- len 2))
1270 (svref coord-seq (- len 1))
1271 2 (- len 4)))
1272 (ecase (line-style-joint-shape line-style)
1273 (:miter
1274 ;;FIXME: Remove successive positively proportional segments
1275 (loop with sin-limit = (sin (* 0.5 miter-limit))
1276 and xn and yn
1277 for i from initial-index to final-index by 2
1278 for xp = initial-xp then x
1279 for yp = initial-yp then y
1280 for x = (svref coord-seq i)
1281 for y = (svref coord-seq (1+ i))
1282 do (setf (values xn yn)
1283 (if (eql i final-index)
1284 (values final-xn final-yn)
1285 (values (svref coord-seq (+ i 2))
1286 (svref coord-seq (+ i
1287 3)))))
1288 (multiple-value-bind (ex1 ey1)
1289 (normalize-coords (- x xp) (- y yp))
1290 (multiple-value-bind (ex2 ey2)
1291 (normalize-coords (- x xn) (- y yn))
1292 (let* ((cos-a (+ (* ex1 ex2) (* ey1 ey2)))
1293 (sin-a/2 (sqrt (* 0.5 (- 1.0 cos-a)))))
1294 (if (< sin-a/2 sin-limit)
1295 (let ((nx (* border
1296 (max (abs ey1) (abs ey2))))
1297 (ny (* border
1298 (max (abs ex1) (abs ex2)))))
1299 (minf min-x (- x nx))
1300 (minf min-y (- y ny))
1301 (maxf max-x (+ x nx))
1302 (maxf max-y (+ y ny)))
1303 (let ((length (/ border sin-a/2)))
1304 (multiple-value-bind (dx dy)
1305 (normalize-coords (+ ex1 ex2)
1306 (+ ey1 ey2)
1307 length)
1308 (minf min-x (+ x dx))
1309 (minf min-y (+ y dy))
1310 (maxf max-x (+ x dx))
1311 (maxf max-y (+ y dy))))))))))
1312 ((:bevel :none)
1313 (loop with xn and yn
1314 for i from initial-index to final-index by 2
1315 for xp = initial-xp then x
1316 for yp = initial-yp then y
1317 for x = (svref coord-seq i)
1318 for y = (svref coord-seq (1+ i))
1319 do (setf (values xn yn)
1320 (if (eql i final-index)
1321 (values final-xn final-yn)
1322 (values (svref coord-seq (+ i 2))
1323 (svref coord-seq (+ i
1324 3)))))
1325 (multiple-value-bind (ex1 ey1)
1326 (normalize-coords (- x xp) (- y yp))
1327 (multiple-value-bind (ex2 ey2)
1328 (normalize-coords (- x xn) (- y yn))
1329 (let ((nx (* border (max (abs ey1) (abs ey2))))
1330 (ny (* border (max (abs ex1) (abs ex2)))))
1331 (minf min-x (- x nx))
1332 (minf min-y (- y ny))
1333 (maxf max-x (+ x nx))
1334 (maxf max-y (+ y ny))))))))
1335 (unless closed
1336 (multiple-value-bind (x y)
1337 (values (svref coord-seq final-index)
1338 (svref coord-seq (1+ final-index)))
1339 (minf min-x (- x border))
1340 (minf min-y (- y border))
1341 (maxf max-x (+ x border))
1342 (maxf max-y (+ y border)))))
1343 (values min-x min-y max-x max-y)))))
1344
1345 (def-grecording draw-polygon ((coord-seq-mixin gs-line-style-mixin)
1346 coord-seq closed filled)
1347 (let ((border (graphics-state-line-style-border graphic medium)))
1348 (polygon-record-bounding-rectangle
1349 coord-seq closed filled line-style border (medium-miter-limit medium))))
1350
1351 (defrecord-predicate draw-polygon-output-record (closed filled)
1352 (and (if-supplied (closed)
1353 (eql (slot-value record 'closed) closed))
1354 (if-supplied (filled)
1355 (eql (slot-value record 'filled) filled))))
1356
1357 (def-grecording draw-rectangle ((gs-line-style-mixin)
1358 left top right bottom filled)
1359 (let ((border (graphics-state-line-style-border graphic medium)))
1360 (polygon-record-bounding-rectangle
1361 (vector left top left bottom right bottom right top)
1362 t filled line-style border
1363 (medium-miter-limit medium))))
1364
1365 (defmethod* (setf output-record-position) :around
1366 (nx ny (record draw-rectangle-output-record))
1367 (with-slots (x1 y1
1368 left top right bottom)
1369 record
1370 (let ((dx (- nx x1))
1371 (dy (- ny y1)))
1372 (multiple-value-prog1
1373 (call-next-method)
1374 (incf left dx)
1375 (incf top dy)
1376 (incf right dx)
1377 (incf bottom dy)))))
1378
1379 (defrecord-predicate draw-rectangle-output-record (left top right bottom filled)
1380 (and (if-supplied (left coordinate)
1381 (coordinate= (slot-value record 'left) left))
1382 (if-supplied (top coordinate)
1383 (coordinate= (slot-value record 'top) top))
1384 (if-supplied (right coordinate)
1385 (coordinate= (slot-value record 'right) right))
1386 (if-supplied (bottom coordinate)
1387 (coordinate= (slot-value record 'bottom) bottom))
1388 (if-supplied (filled)
1389 (eql (slot-value record 'filled) filled))))
1390
1391 (def-grecording draw-ellipse ((gs-line-style-mixin)
1392 center-x center-y
1393 radius-1-dx radius-1-dy radius-2-dx radius-2-dy
1394 start-angle end-angle filled)
1395 (multiple-value-bind (min-x min-y max-x max-y)
1396 (bounding-rectangle* (make-ellipse* center-x center-y
1397 radius-1-dx radius-1-dy
1398 radius-2-dx radius-2-dy
1399 :start-angle start-angle
1400 :end-angle end-angle))
1401 (if filled
1402 (values min-x min-y max-x max-y)
1403 (let ((border (graphics-state-line-style-border graphic medium)))
1404 (values (- min-x border)
1405 (- min-y border)
1406 (+ max-x border)
1407 (+ max-y border))))))
1408
1409 (defmethod* (setf output-record-position) :around
1410 (nx ny (record draw-ellipse-output-record))
1411 (with-slots (x1 y1 center-x center-y)
1412 record
1413 (let ((dx (- nx x1))
1414 (dy (- ny y1)))
1415 (multiple-value-prog1
1416 (call-next-method)
1417 (incf center-x dx)
1418 (incf center-y dy)))))
1419
1420 (defrecord-predicate draw-ellipse-output-record (center-x center-y)
1421 (and (if-supplied (center-x coordinate)
1422 (coordinate= (slot-value record 'center-x) center-x))
1423 (if-supplied (center-y coordinate)
1424 (coordinate= (slot-value record 'center-y) center-y))))
1425
1426 ;;;; Patterns
1427
1428 (def-grecording draw-pattern (() pattern x y)
1429 (let ((width (pattern-width pattern))
1430 (height (pattern-height pattern)))
1431 (values x y (+ x width) (+ y height))))
1432
1433 (defmethod* (setf output-record-position) :around (nx ny (record draw-pattern-output-record))
1434 (with-slots (x1 y1 x y)
1435 record
1436 (let ((dx (- nx x1))
1437 (dy (- ny y1)))
1438 (multiple-value-prog1
1439 (call-next-method)
1440 (incf x dx)
1441 (incf y dy)))))
1442
1443 (defrecord-predicate draw-pattern-output-record (x y pattern)
1444 ;; ### I am not so sure about the correct usage of DEFRECORD-PREDICATE
1445 ;; --GB 2003-08-15
1446 (and (if-supplied (x coordinate)
1447 (coordinate= (slot-value record 'x) x))
1448 (if-supplied (y coordinate)
1449 (coordinate= (slot-value record 'y) y))
1450 (if-supplied (pattern pattern)
1451 (eq (slot-value record 'pattern) pattern))))
1452
1453 ;;;; Text
1454
1455 (def-grecording draw-text ((gs-text-style-mixin) string point-x point-y start end
1456 align-x align-y toward-x toward-y transform-glyphs)
1457 ;; FIXME!!! Text direction.
1458 ;; Multiple lines?
1459 (let* ((text-style (graphics-state-text-style graphic))
1460 (width (if (characterp string)
1461 (stream-character-width stream string :text-style text-style)
1462 (stream-string-width stream string
1463 :start start :end end
1464 :text-style text-style)) )
1465 (ascent (text-style-ascent text-style (sheet-medium stream)))
1466 (descent (text-style-descent text-style (sheet-medium stream)))
1467 (height (+ ascent descent))
1468 left top right bottom)
1469 (ecase align-x
1470 (:left (setq left point-x
1471 right (+ point-x width)))
1472 (:right (setq left (- point-x width)
1473 right point-x))
1474 (:center (setq left (- point-x (round width 2))
1475 right (+ point-x (round width 2)))))
1476 (ecase align-y
1477 (:baseline (setq top (- point-y ascent)
1478 bottom (+ point-y descent)))
1479 (:top (setq top point-y
1480 bottom (+ point-y height)))
1481 (:bottom (setq top (- point-y height)
1482 bottom point-y))
1483 (:center (setq top (- point-y (floor height 2))
1484 bottom (+ point-y (ceiling height 2)))))
1485 (values left top right bottom)))
1486
1487 (defmethod* (setf output-record-position) :around
1488 (nx ny (record draw-text-output-record))
1489 (with-slots (x1 y1 point-x point-y toward-x toward-y)
1490 record
1491 (let ((dx (- nx x1))
1492 (dy (- ny y1)))
1493 (multiple-value-prog1
1494 (call-next-method)
1495 (incf point-x dx)
1496 (incf point-y dy)
1497 (incf toward-x dx)
1498 (incf toward-y dy)))))
1499
1500 (defrecord-predicate draw-text-output-record
1501 (string start end point-x point-y align-x align-y toward-x toward-y
1502 transform-glyphs)
1503 (and (if-supplied (string)
1504 (string= (slot-value record 'string) string))
1505 (if-supplied (start)
1506 (eql (slot-value record 'start) start))
1507 (if-supplied (end)
1508 (eql (slot-value record 'end) end))
1509 (if-supplied (point-x coordinate)
1510 (coordinate= (slot-value record 'point-x) point-x))
1511 (if-supplied (point-y coordinate)
1512 (coordinate= (slot-value record 'point-y) point-y))
1513 (if-supplied (align-x)
1514 (eq (slot-value record 'align-x) align-x))
1515 (if-supplied (align-y)
1516 (eq (slot-value record 'align-y) align-y))
1517 (if-supplied (toward-x coordinate)
1518 (coordinate= (slot-value record 'toward-x) toward-x))
1519 (if-supplied (toward-y coordinate)
1520 (coordinate= (slot-value record 'toward-y) toward-y))
1521 (if-supplied (transform-glyphs)
1522 (eq (slot-value record 'transform-glyphs) transform-glyphs))))
1523
1524 ;;; 16.3.3. Text Displayed Output Record
1525
1526 (defclass styled-string (gs-text-style-mixin gs-clip-mixin gs-ink-mixin)
1527 ((start-x :initarg :start-x)
1528 (string :initarg :string :reader styled-string-string)))
1529
1530 (defmethod output-record-equal and ((record styled-string)
1531 (record2 styled-string))
1532 (and (coordinate= (slot-value record 'start-x)
1533 (slot-value record2 'start-x))
1534 (string= (slot-value record 'string)
1535 (slot-value record2 'string))))
1536
1537 (defclass standard-text-displayed-output-record
1538 (text-displayed-output-record standard-displayed-output-record)
1539 ((initial-x1 :initarg :start-x)
1540 (initial-y1 :initarg :start-y)
1541 (strings :initform nil)
1542 (baseline :initform 0)
1543 (width :initform 0)
1544 (max-height :initform 0)
1545 (start-x :initarg :start-x)
1546 (start-y :initarg :start-y)
1547 (end-x :initarg :start-x)
1548 (end-y :initarg :start-y)
1549 (wrapped :initform nil
1550 :accessor text-record-wrapped)
1551 (medium :initarg :medium :initform nil)))
1552
1553 (defmethod initialize-instance :after
1554 ((obj standard-text-displayed-output-record) &key stream)
1555 (when stream
1556 (setf (slot-value obj 'medium) (sheet-medium stream))))
1557
1558 ;;; Forget match-output-records-1 for standard-text-displayed-output-record; it
1559 ;;; doesn't make much sense because these records have state that is not
1560 ;;; initialized via initargs.
1561
1562 (defmethod output-record-equal and
1563 ((record standard-text-displayed-output-record)
1564 (record2 standard-text-displayed-output-record))
1565 (with-slots
1566 (initial-x1 initial-y1 start-x start-y end-x end-y wrapped strings)
1567 record2
1568 (and (coordinate= (slot-value record 'initial-x1) initial-x1)
1569 (coordinate= (slot-value record 'initial-y1) initial-y1)
1570 (coordinate= (slot-value record 'start-x) start-x)
1571 (coordinate= (slot-value record 'start-y) start-y)
1572 (coordinate= (slot-value record 'end-x) end-x)
1573 (coordinate= (slot-value record 'end-y) end-y)
1574 (eq (slot-value record 'wrapped) wrapped)
1575 (coordinate= (slot-value record 'baseline)
1576 (slot-value record2 'baseline))
1577 (eql (length (slot-value record 'strings)) (length strings));XXX
1578 (loop for s1 in (slot-value record 'strings)
1579 for s2 in strings
1580 always (output-record-equal s1 s2)))))
1581
1582 (defmethod print-object ((self standard-text-displayed-output-record) stream)
1583 (print-unreadable-object (self stream :type t :identity t)
1584 (with-slots (start-x start-y strings) self
1585 (format stream "~D,~D ~S"
1586 start-x start-y
1587 (mapcar #'styled-string-string strings)))))
1588
1589 (defmethod* (setf output-record-position) :before
1590 (nx ny (record standard-text-displayed-output-record))
1591 (with-slots (x1 y1 start-x start-y end-x end-y strings) record
1592 (let ((dx (- nx x1))
1593 (dy (- ny y1)))
1594 (incf start-x dx)
1595 (incf start-y dy)
1596 (incf end-x dx)
1597 (incf end-y dy)
1598 (loop for s in strings
1599 do (incf (slot-value s 'start-x) dx)))))
1600
1601 (defmethod replay-output-record ((record standard-text-displayed-output-record)
1602 stream
1603 &optional region (x-offset 0) (y-offset 0))
1604 (declare (ignore region x-offset y-offset))
1605 (with-slots (strings baseline max-height start-y wrapped x1 y1)
1606 record
1607 (with-sheet-medium (medium stream) ;is sheet a sheet-with-medium-mixin? --GB
1608 ;; FIXME:
1609 ;; 1. SLOT-VALUE...
1610 ;; 2. It should also save a "current line".
1611 (setf (slot-value stream 'baseline) baseline)
1612 (loop for substring in strings
1613 do (with-slots (start-x string)
1614 substring
1615 (setf (stream-cursor-position stream)
1616 (values start-x start-y))
1617 (set-medium-graphics-state substring medium)
1618 (stream-write-output stream string)))
1619 (when wrapped ; FIXME
1620 (draw-rectangle* medium
1621 (+ wrapped 0) start-y
1622 (+ wrapped 4) (+ start-y max-height)
1623 :ink +foreground-ink+
1624 :filled t)))))
1625
1626 (defmethod output-record-start-cursor-position
1627 ((record standard-text-displayed-output-record))
1628 (with-slots (start-x start-y) record
1629 (values start-x start-y)))
1630
1631 (defmethod output-record-end-cursor-position
1632 ((record standard-text-displayed-output-record))
1633 (with-slots (end-x end-y) record
1634 (values end-x end-y)))
1635
1636 (defmethod tree-recompute-extent
1637 ((text-record standard-text-displayed-output-record))
1638 (with-slots (parent x1 y1 x2 y2 width max-height) text-record
1639 (setq x2 (coordinate (+ x1 width))
1640 y2 (coordinate (+ y1 max-height))))
1641 text-record)
1642
1643 (defmethod add-character-output-to-text-record ; XXX OAOO with ADD-STRING-...
1644 ((text-record standard-text-displayed-output-record)
1645 character text-style char-width height new-baseline)
1646 (with-slots (strings baseline width max-height start-y end-x end-y medium)
1647 text-record
1648 (if (and strings
1649 (let ((string (last1 strings)))
1650 (match-output-records string
1651 :text-style text-style
1652 :ink (medium-ink medium)
1653 :clipping-region (medium-clipping-region
1654 medium))))
1655 (vector-push-extend character (slot-value (last1 strings) 'string))
1656 (nconcf strings
1657 (list (make-instance
1658 'styled-string
1659 :start-x end-x
1660 :text-style text-style
1661 :medium medium ; pick up ink and clipping region
1662 :string (make-array 1 :initial-element character
1663 :element-type 'character
1664 :adjustable t
1665 :fill-pointer t)))))
1666 (setq baseline (max baseline new-baseline)
1667 end-x (+ end-x char-width)
1668 max-height (max max-height height)
1669 end-y (max end-y (+ start-y max-height))
1670 width (+ width char-width)))
1671 (tree-recompute-extent text-record))
1672
1673 (defmethod add-string-output-to-text-record
1674 ((text-record standard-text-displayed-output-record)
1675 string start end text-style string-width height new-baseline)
1676 (setf end (or end (length string)))
1677 (let ((length (max 0 (- end start))))
1678 (cond
1679 ((eql length 1)
1680 (add-character-output-to-text-record text-record
1681 (aref string start)
1682 text-style
1683 string-width height new-baseline))
1684 (t (with-slots (strings baseline width max-height start-y end-x end-y
1685 medium)
1686 text-record
1687 (let ((styled-string (make-instance
1688 'styled-string
1689 :start-x end-x
1690 :text-style text-style
1691 :medium medium
1692 :string (make-array length
1693 :element-type 'character
1694 :adjustable t
1695 :fill-pointer t))))
1696 (nconcf strings (list styled-string))
1697 (replace (styled-string-string styled-string) string
1698 :start2 start :end2 end))
1699 (setq baseline (max baseline new-baseline)
1700 end-x (+ end-x string-width)
1701 max-height (max max-height height)
1702 end-y (max end-y (+ start-y max-height))
1703 width (+ width string-width)))
1704 (tree-recompute-extent text-record)))))
1705
1706 (defmethod text-displayed-output-record-string
1707 ((record standard-text-displayed-output-record))
1708 (with-output-to-string (result)
1709 (with-slots (strings) record
1710 (loop for (nil nil substring) in strings
1711 do (write-string substring result)))))
1712
1713 ;;; 16.3.4. Top-Level Output Records
1714 (defclass stream-output-history-mixin ()
1715 ())
1716
1717 (defclass standard-sequence-output-history
1718 (standard-sequence-output-record stream-output-history-mixin)
1719 ())
1720
1721 (defclass standard-tree-output-history
1722 (standard-tree-output-record stream-output-history-mixin)
1723 ())
1724
1725 ;;; 16.4. Output Recording Streams
1726 (defclass standard-output-recording-stream (output-recording-stream)
1727 ((recording-p :initform t :reader stream-recording-p)
1728 (drawing-p :initform t :accessor stream-drawing-p)
1729 (output-history :initform (make-instance 'standard-tree-output-history)
1730 :reader stream-output-history)
1731 (current-output-record :accessor stream-current-output-record)
1732 (current-text-output-record :initform nil
1733 :accessor stream-current-text-output-record)
1734 (local-record-p :initform t
1735 :documentation "This flag is used for dealing with streams outputting strings char-by-char.")))
1736
1737 (defmethod initialize-instance :after
1738 ((stream standard-output-recording-stream) &rest args)
1739 (declare (ignore args))
1740 (setf (stream-current-output-record stream) (stream-output-history stream)))
1741
1742 ;;; Used in initializing clim-stream-pane
1743
1744 (defmethod reset-output-history ((stream
1745 standard-output-recording-stream))
1746 (setf (slot-value stream 'output-history)
1747 (make-instance 'standard-tree-output-history))
1748 (setf (stream-current-output-record stream) (stream-output-history stream)))
1749
1750 ;;; 16.4.1 The Output Recording Stream Protocol
1751 (defmethod (setf stream-recording-p)
1752 (recording-p (stream standard-output-recording-stream))
1753 (let ((old-val (slot-value stream 'recording-p)))
1754 (setf (slot-value stream 'recording-p) recording-p)
1755 (when (not (eq old-val recording-p))
1756 (stream-close-text-output-record stream))
1757 recording-p))
1758
1759 (defmethod stream-add-output-record
1760 ((stream standard-output-recording-stream) record)
1761 (add-output-record record (stream-current-output-record stream)))
1762
1763 (defmethod stream-replay
1764 ((stream standard-output-recording-stream) &optional region)
1765 (replay (stream-output-history stream) stream region))
1766
1767 (defun output-record-ancestor-p (ancestor child)
1768 (loop for record = child then parent
1769 for parent = (output-record-parent record)
1770 when (eq parent nil) do (return nil)
1771 when (eq parent ancestor) do (return t)))
1772
1773 (defmethod erase-output-record (record (stream standard-output-recording-stream)
1774 &optional (errorp t))
1775 (letf (((stream-recording-p stream) nil))
1776 (let ((region (bounding-rectangle record)))
1777 (with-bounding-rectangle* (x1 y1 x2 y2) region
1778 (if (output-record-ancestor-p (stream-output-history stream) record)
1779 (progn
1780 (delete-output-record record (output-record-parent record))
1781 (with-output-recording-options (stream :record nil)
1782 (draw-rectangle* stream x1 y1 x2 y2 :ink +background-ink+))
1783 (stream-replay stream region))
1784 (when errorp
1785 (error "~S is not contained in ~S." record stream)))))))
1786
1787 ;;; 16.4.3. Text Output Recording
1788 (defmethod stream-text-output-record
1789 ((stream standard-output-recording-stream) text-style)
1790 (declare (ignore text-style))
1791 (let ((record (stream-current-text-output-record stream)))
1792 (unless (and record (typep record 'standard-text-displayed-output-record))
1793 (multiple-value-bind (cx cy) (stream-cursor-position stream)
1794 (setf record (make-instance 'standard-text-displayed-output-record
1795 :x-position cx :y-position cy
1796 :start-x cx :start-y cy
1797 :stream stream)
1798 (stream-current-text-output-record stream) record)))
1799 record))
1800
1801 (defmethod stream-close-text-output-record
1802 ((stream standard-output-recording-stream))
1803 (let ((record (stream-current-text-output-record stream)))
1804 (when record
1805 (setf (stream-current-text-output-record stream) nil)
1806 #|record stream-current-cursor-position to (end-x record) - already done|#
1807 (stream-add-output-record stream record))))
1808
1809 (defmethod stream-add-character-output
1810 ((stream standard-output-recording-stream)
1811 character text-style width height baseline)
1812 (add-character-output-to-text-record
1813 (stream-text-output-record stream text-style)
1814 character text-style width height baseline))
1815
1816 (defmethod stream-add-string-output ((stream standard-output-recording-stream)
1817 string start end text-style
1818 width height baseline)
1819 (add-string-output-to-text-record (stream-text-output-record stream
1820 text-style)
1821 string start end text-style
1822 width height baseline))
1823
1824 ;;; Text output catching methods
1825 (defmacro without-local-recording (stream &body body)
1826 `(letf (((slot-value ,stream 'local-record-p) nil))
1827 ,@body))
1828
1829 (defmethod stream-write-output :around
1830 ((stream standard-output-recording-stream) line
1831 &optional (start 0) end)
1832 (when (and (stream-recording-p stream)
1833 (slot-value stream 'local-record-p))
1834 (let* ((medium (sheet-medium stream))
1835 (text-style (medium-text-style medium))
1836 (height (text-style-height text-style medium))
1837 (ascent (text-style-ascent text-style medium)))
1838 (if (characterp line)
1839 (stream-add-character-output stream line text-style
1840 (stream-character-width
1841 stream line :text-style text-style)
1842 height
1843 ascent)
1844 (stream-add-string-output stream line start end text-style
1845 (stream-string-width stream line
1846 :start start :end end
1847 :text-style text-style)
1848
1849 height
1850 ascent))))
1851 (when (stream-drawing-p stream)
1852 (without-local-recording stream
1853 (call-next-method))))
1854
1855 #+nil
1856 (defmethod stream-write-char :around ((stream standard-output-recording-stream) char)
1857 (when (and (stream-recording-p stream)
1858 (slot-value stream 'local-record-p))
1859 (if (or (eql char #\return)
1860
1861 (stream-close-text-output-record stream)
1862 (let* ((medium (sheet-medium stream))
1863 (text-style (medium-text-style medium)))
1864 (stream-add-character-output stream char text-style
1865 (stream-character-width stream char :text-style text-style)
1866 (text-style-height text-style medium)
1867 (text-style-ascent text-style medium)))))
1868 (without-local-recording stream
1869 (call-next-method))))
1870
1871 #+nil
1872 (defmethod stream-write-string :around ((stream standard-output-recording-stream) string
1873 &optional (start 0) end)
1874 (when (and (stream-recording-p stream)
1875 (slot-value stream 'local-record-p))
1876 (let* ((medium (sheet-medium stream))
1877 (text-style (medium-text-style medium)))
1878 (stream-add-string-output stream string start end text-style
1879 (stream-string-width stream string
1880 :start start :end end
1881 :text-style text-style)
1882 (text-style-height text-style medium)
1883 (text-style-ascent text-style medium))))
1884 (without-local-recording stream
1885 (call-next-method)))
1886
1887
1888 (defmethod stream-finish-output :after ((stream standard-output-recording-stream))
1889 (stream-close-text-output-record stream))
1890
1891 (defmethod stream-force-output :after ((stream standard-output-recording-stream))
1892 (stream-close-text-output-record stream))
1893
1894 (defmethod stream-terpri :after ((stream standard-output-recording-stream))
1895 (stream-close-text-output-record stream))
1896
1897 (defmethod* (setf stream-cursor-position) :after (x y (stream standard-output-recording-stream))
1898 (declare (ignore x y))
1899 (stream-close-text-output-record stream))
1900
1901 ;(defmethod stream-set-cursor-position :after ((stream standard-output-recording-stream))
1902 ; (stream-close-text-output-record stream))
1903
1904 (defmethod stream-wrap-line :before ((stream standard-output-recording-stream))
1905 (when (stream-recording-p stream)
1906 (setf (text-record-wrapped (stream-text-output-record stream nil)) ; FIXME!
1907 (stream-text-margin stream))))
1908
1909 ;;; 16.4.4. Output Recording Utilities
1910
1911 (defmethod invoke-with-output-recording-options
1912 ((stream output-recording-stream) continuation record draw)
1913 "Calls CONTINUATION on STREAM enabling or disabling recording and drawing
1914 according to the flags RECORD and DRAW."
1915 (letf (((stream-recording-p stream) record)
1916 ((stream-drawing-p stream) draw))
1917 (funcall continuation stream)))
1918
1919 (defmethod invoke-with-new-output-record ((stream output-recording-stream)
1920 continuation record-type
1921 &rest initargs
1922 &key
1923 &allow-other-keys)
1924 (stream-close-text-output-record stream)
1925 (let ((new-record (apply #'make-instance record-type initargs)))
1926 (stream-add-output-record stream new-record)
1927 (letf (((stream-current-output-record stream) new-record))
1928 ;; Should we switch on recording? -- APD
1929 (funcall continuation stream new-record)
1930 (finish-output stream))
1931 new-record))
1932
1933 (defmethod invoke-with-output-to-output-record
1934 ((stream output-recording-stream) continuation record-type
1935 &rest initargs
1936 &key
1937 &allow-other-keys)
1938 (stream-close-text-output-record stream)
1939 (let ((new-record (apply #'make-instance record-type initargs)))
1940 (with-output-recording-options (stream :record t :draw nil)
1941 (letf (((stream-current-output-record stream) new-record)
1942 ((stream-cursor-position stream) (values 0 0)))
1943 (funcall continuation stream new-record)
1944 (finish-output stream)))
1945 new-record))
1946
1947 (defmethod make-design-from-output-record (record)
1948 ;; FIXME
1949 (declare (ignore record))
1950 (error "Not implemented."))
1951
1952
1953 ;;; Additional methods
1954 (defmethod scroll-vertical :around ((stream output-recording-stream) dy)
1955 (declare (ignore dy))
1956 (with-output-recording-options (stream :record nil)
1957 (call-next-method)))
1958
1959 (defmethod scroll-horizontal :around ((stream output-recording-stream) dx)
1960 (declare (ignore dx))
1961 (with-output-recording-options (stream :record nil)
1962 (call-next-method)))
1963
1964 (defmethod handle-repaint ((stream output-recording-stream) region)
1965 ;; FIXME: Change things so the rectangle below is only drawn in response
1966 ;; to explicit repaint requests from the user, not exposes from X
1967 ;; FIXME: Use DRAW-DESIGN*, that is fix DRAW-DESIGN*.
1968 (setf region (bounding-rectangle region))
1969 (with-bounding-rectangle* (x1 y1 x2 y2) region
1970 (with-output-recording-options (stream :record nil)
1971 (draw-rectangle* stream x1 y1 x2 y2 :filled T :ink +background-ink+)))
1972 (stream-replay stream region))
1973
1974 (defmethod scroll-extent :around ((stream output-recording-stream) x y)
1975 (when (stream-drawing-p stream)
1976 (call-next-method)))
1977
1978 ;;; ----------------------------------------------------------------------------
1979
1980 (defmethod invoke-with-room-for-graphics (cont stream
1981 &key (first-quadrant t)
1982 height
1983 (move-cursor t)
1984 (record-type 'standard-sequence-output-record))
1985 ;; I am not sure what exactly :height should do.
1986 ;; --GB 2003-05-25
1987 (multiple-value-bind (cx cy)
1988 (stream-cursor-position stream)
1989 (let ((record
1990 (with-output-recording-options (stream :draw nil :record t)
1991 (with-new-output-record (stream record-type)
1992 (with-drawing-options
1993 (stream :transformation
1994 (if first-quadrant
1995 (make-scaling-transformation 1 -1)
1996 +identity-transformation+))
1997 (funcall cont stream))))))
1998 (cond ((null height)
1999 (setf (output-record-position record)
2000 (values cx cy)))
2001 (t
2002 (setf (output-record-position record)
2003 (values cx (- cy (- (bounding-rectangle-height record) height))))))
2004 (with-output-recording-options (stream :draw t :record nil)
2005 (replay-output-record record stream))
2006 (cond (move-cursor
2007 (setf (stream-cursor-position stream)
2008 (values (bounding-rectangle-max-x record)
2009 (bounding-rectangle-max-y record))))
2010 (t
2011 (setf (stream-cursor-position stream)
2012 (values cx cy)))))))
2013
2014
2015 (defmethod repaint-sheet ((sheet output-recording-stream) region)
2016 (map-over-sheets-overlapping-region #'(lambda (s)
2017 (handle-repaint s region))
2018 sheet
2019 region))
2020
2021 ;;; ----------------------------------------------------------------------------
2022 ;;; Baseline
2023 ;;;
2024
2025 (defmethod output-record-baseline ((record output-record))
2026 "Fall back method"
2027 (values
2028 (bounding-rectangle-max-y record)
2029 nil))
2030
2031 (defmethod output-record-baseline ((record standard-text-displayed-output-record))
2032 (with-slots (baseline) record
2033 (values
2034 baseline
2035 t)))
2036
2037 (defmethod output-record-baseline ((record compound-output-record))
2038 (map-over-output-records (lambda (sub-record)
2039 (multiple-value-bind (baseline definitive)
2040 (output-record-baseline sub-record)
2041 (when definitive
2042 (return-from output-record-baseline
2043 (values baseline t)))))
2044 record)
2045 (values (bounding-rectangle-max-y record) nil))
2046
2047 ;;; ----------------------------------------------------------------------------
2048 ;;; copy-textual-output
2049 ;;;
2050
2051 (defun copy-textual-output-history (window stream &optional region record)
2052 (unless region (setf region +everywhere+))
2053 (unless record (setf record (stream-output-history window)))
2054 (let* ((text-style (medium-default-text-style window))
2055 (char-width (stream-character-width window #\n :text-style text-style))
2056 (line-height (+ (stream-line-height window :text-style text-style)
2057 (stream-vertical-spacing window))))
2058 #+NIL
2059 (print (list char-width line-height
2060 (stream-line-height window :text-style text-style)
2061 (stream-vertical-spacing window))
2062 *trace-output*)
2063 ;; humble first ...
2064 (let ((cy nil)
2065 (cx 0))
2066 (labels ((grok-record (record)
2067 (cond ((typep record 'standard-text-displayed-output-record)
2068 (with-slots (start-y start-x end-x strings) record
2069 (setf cy (or cy start-y))
2070 #+NIL
2071 (print (list (list cx cy)
2072 (list start-x end-x start-y))
2073 *trace-output*)
2074 (when (> start-y cy)
2075 (dotimes (k (round (- start-y cy) line-height))
2076 (terpri stream))
2077 (setf cy start-y
2078 cx 0))
2079 (dotimes (k (round (- start-x cx) char-width))
2080 (princ " " stream))
2081 (setf cx end-x)
2082 (dolist (string strings)
2083 (with-slots (string) string
2084 (princ string stream))
2085 #+NIL
2086 (print (list start-x start-y string)
2087 *trace-output*))))
2088 (t
2089 (map-over-output-records-overlapping-region #'grok-record
2090 record region)))))
2091 (grok-record record)))))

  ViewVC Help
Powered by ViewVC 1.1.5