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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.118 - (show annotations)
Tue Feb 15 11:28:11 2005 UTC (9 years, 2 months ago) by crhodes
Branch: MAIN
CVS Tags: McCLIM-0-9-1
Changes since 1.117: +2 -0 lines
Maybe fix circle/ellipse drawing in with-room-for-graphics and
with-first-quadrant-coordinates.

(Weirdest.  Coordinate.  System.  Ever.)
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
188 (defgeneric map-over-output-records-1
189 (continuation record continuation-args))
190
191 (defun map-over-output-records
192 (continuation record &optional x-offset y-offset &rest continuation-args)
193 (declare (ignore x-offset y-offset))
194 (map-over-output-records-1 continuation record continuation-args))
195
196 ;;; 16.2.3. Output Record Change Notification Protocol
197
198 (defgeneric recompute-extent-for-new-child (record child))
199
200 (defgeneric recompute-extent-for-changed-child
201 (record child old-min-x old-min-y old-max-x old-max-y))
202
203 (defgeneric tree-recompute-extent (record))
204
205 ;;; 16.3. Types of Output Records
206 (define-protocol-class graphics-displayed-output-record
207 (displayed-output-record)
208 ())
209
210 (define-protocol-class text-displayed-output-record (displayed-output-record)
211 ())
212
213 ;;; 16.3.3. Text Displayed Output Record
214 (defgeneric add-character-output-to-text-record
215 (text-record character text-style width height baseline))
216
217 (defgeneric add-string-output-to-text-record
218 (text-record string start end text-style width height baseline))
219
220 (defgeneric text-displayed-output-record-string (text-record))
221
222 ;;; 16.4. Output Recording Streams
223 (define-protocol-class output-recording-stream ()
224 ())
225
226 ;;; 16.4.1. The Output Recording Stream Protocol
227 (defgeneric stream-recording-p (stream))
228
229 (defgeneric (setf stream-recording-p) (recording-p stream))
230
231 (defgeneric stream-drawing-p (stream))
232
233 (defgeneric (setf stream-drawing-p) (drawing-p stream))
234
235 (defgeneric stream-output-history (stream))
236
237 (defgeneric stream-current-output-record (stream))
238
239 (defgeneric (setf stream-current-output-record) (record stream))
240
241 (defgeneric stream-add-output-record (stream record))
242
243 (defgeneric stream-replay (stream &optional region))
244
245 (defgeneric erase-output-record (record stream &optional errorp))
246
247 ;;; 16.4.3. Text Output Recording
248 (defgeneric stream-text-output-record (stream text-style))
249
250 (defgeneric stream-close-text-output-record (stream))
251
252 (defgeneric stream-add-character-output
253 (stream character text-style width height baseline))
254
255 (defgeneric stream-add-string-output
256 (stream string start end text-style width height baseline))
257
258 ;;; 16.4.4. Output Recording Utilities
259 (defgeneric invoke-with-output-recording-options
260 (stream continuation record draw))
261
262 ;; The 'constructor' arg is absent from the CLIM 2.0 spec but is documented
263 ;; in the Allegro CLIM 2 User Guide and appears to exist in other 'classic'
264 ;; CLIM implementations. I'm assuming it's an omission from the spec.
265 (defgeneric invoke-with-new-output-record
266 (stream continuation record-type constructor
267 &key &allow-other-keys))
268
269 (defgeneric invoke-with-output-to-output-record
270 (stream continuation record-type constructor
271 &rest initargs
272 &key
273 &allow-other-keys))
274
275 (defgeneric make-design-from-output-record (record))
276
277 ;;; 21.3 Incremental Redisplay Protocol. These generic functions need
278 ;;; to be implemented for all the basic displayed-output-records, so they are
279 ;;; defined in this file.
280 ;;;
281 ;;; match-output-records and find-child-output-record, as defined in
282 ;;; the CLIM spec, are pretty silly. How does incremental redisplay know
283 ;;; what keyword arguments to supply to find-child-output-record? Through
284 ;;; a gf specialized on the type of the record it needs to match... why
285 ;;; not define the search function and the predicate on two records then!
286 ;;;
287 ;;; We'll implement match-output-records and find-child-output-record,
288 ;;; but we won't actually use them. Instead, output-record-equal will
289 ;;; match two records, and find-child-record-equal will search for the
290 ;;; equivalent record.
291
292 (defgeneric match-output-records (record &rest args))
293
294 ;;; These gf's use :most-specific-last because one of the least
295 ;;; specific methods will check the bounding boxes of the records, which
296 ;;; should cause an early out most of the time.
297
298 (defgeneric match-output-records-1 (record &key)
299 (:method-combination and :most-specific-last))
300
301 (defgeneric output-record-equal (record1 record2)
302 (:method-combination and :most-specific-last))
303
304 (defmethod output-record-equal :around (record1 record2)
305 (cond ((eq record1 record2)
306 ;; Some unusual record -- like a Goatee screen line -- might
307 ;; exist in two trees at once
308 t)
309 ((eq (class-of record1) (class-of record2))
310 (let ((result (call-next-method)))
311 (if (eq result 'maybe)
312 nil
313 result)))
314 (t nil)))
315
316 ;;; A fallback method so that something's always applicable.
317
318 (defmethod output-record-equal and (record1 record2)
319 (declare (ignore record1 record2))
320 'maybe)
321
322 ;;; The code for match-output-records-1 and output-record-equal
323 ;;; methods are very similar, hence this macro. In order to exploit
324 ;;; the similarities, it's necessary to treat the slots of the second
325 ;;; record like variables, so for convenience the macro will use
326 ;;; slot-value on both records.
327
328 (defmacro defrecord-predicate (record-type slots &body body)
329 "Each element of SLOTS is either a symbol or (:initarg-name slot-name)."
330 (let* ((slot-names (mapcar #'(lambda (slot-spec)
331 (if (consp slot-spec)
332 (cadr slot-spec)
333 slot-spec))
334 slots))
335 (supplied-vars (mapcar #'(lambda (slot)
336 (gensym (symbol-name
337 (symbol-concat slot '#:-p))))
338 slot-names))
339 (key-args (mapcar #'(lambda (slot-spec supplied)
340 `(,slot-spec nil ,supplied))
341 slots supplied-vars))
342 (key-arg-alist (mapcar #'cons slot-names supplied-vars)))
343 `(progn
344 (defmethod output-record-equal and ((record ,record-type)
345 (record2 ,record-type))
346 (macrolet ((if-supplied ((var &optional (type t)) &body supplied-body)
347 (declare (ignore var type))
348 `(progn ,@supplied-body)))
349 (with-slots ,slot-names
350 record2
351 ,@body)))
352 (defmethod match-output-records-1 and ((record ,record-type)
353 &key ,@key-args)
354 (macrolet ((if-supplied ((var &optional (type t)) &body supplied-body)
355 (let ((supplied-var (cdr (assoc var ',key-arg-alist))))
356 (unless supplied-var
357 (error "Unknown slot ~S" var))
358 `(or (null ,supplied-var)
359 ,@(if (eq type t)
360 `((progn ,@supplied-body))
361 `((if (typep ,var ',type)
362 (progn ,@supplied-body)
363 (error 'type-error
364 :datum ,var
365 :expected-type ',type))))))))
366 ,@body)))
367
368 ))
369 ;;; Macros
370 (defmacro with-output-recording-options ((stream
371 &key (record nil record-supplied-p)
372 (draw nil draw-supplied-p))
373 &body body)
374 (setq stream (stream-designator-symbol stream '*standard-output*))
375 (with-gensyms (continuation)
376 `(flet ((,continuation (,stream)
377 (declare (ignorable ,stream))
378 ,@body))
379 (declare (dynamic-extent #',continuation))
380 (invoke-with-output-recording-options
381 ,stream #',continuation
382 ,(if record-supplied-p record `(stream-recording-p ,stream))
383 ,(if draw-supplied-p draw `(stream-drawing-p ,stream))))))
384
385 ;;; Macro masturbation...
386
387 (defmacro define-invoke-with (macro-name func-name record-type doc-string)
388 `(defmacro ,macro-name ((stream
389 &optional
390 (record-type '',record-type)
391 (record (gensym))
392 &rest initargs)
393 &body body)
394 ,doc-string
395 (setq stream (stream-designator-symbol stream '*standard-output*))
396 (with-gensyms (constructor continuation)
397 (multiple-value-bind (bindings m-i-args)
398 (rebind-arguments initargs)
399 `(let ,bindings
400 (flet ((,constructor ()
401 (make-instance ,record-type ,@m-i-args))
402 (,continuation (,stream ,record)
403 (declare (ignorable ,stream ,record))
404 ,@body))
405 (declare (dynamic-extent #'constructor #'continuation))
406 (,',func-name ,stream #',continuation ,record-type #',constructor
407 ,@m-i-args)))))))
408
409 (define-invoke-with with-new-output-record invoke-with-new-output-record
410 standard-sequence-output-record
411 "Creates a new output record of type RECORD-TYPE and then captures
412 the output of BODY into the new output record, and inserts the new
413 record into the current \"open\" output record assotiated with STREAM.
414 If RECORD is supplied, it is the name of a variable that will be
415 lexically bound to the new output record inside the body. INITARGS are
416 CLOS initargs that are passed to MAKE-INSTANCE when the new output
417 record is created.
418 It returns the created output record.
419 The STREAM argument is a symbol that is bound to an output
420 recording stream. If it is T, *STANDARD-OUTPUT* is used.")
421
422 (define-invoke-with with-output-to-output-record
423 invoke-with-output-to-output-record
424 standard-sequence-output-record
425 "Creates a new output record of type RECORD-TYPE and then captures
426 the output of BODY into the new output record. The cursor position of
427 STREAM is initially bound to (0,0)
428 If RECORD is supplied, it is the name of a variable that will be
429 lexically bound to the new output record inside the body. INITARGS are
430 CLOS initargs that are passed to MAKE-INSTANCE when the new output
431 record is created.
432 It returns the created output record.
433 The STREAM argument is a symbol that is bound to an output
434 recording stream. If it is T, *STANDARD-OUTPUT* is used.")
435
436
437 ;;;; Implementation
438
439 (defclass basic-output-record (standard-bounding-rectangle output-record)
440 ((parent :initarg :parent ; XXX
441 :initform nil
442 :accessor output-record-parent)) ; XXX
443 (:documentation "Implementation class for the Basic Output Record Protocol."))
444
445 (defmethod initialize-instance :after ((record basic-output-record)
446 &key (x-position 0.0d0)
447 (y-position 0.0d0))
448 (declare (ignore args))
449 (setf (rectangle-edges* record)
450 (values x-position y-position x-position y-position)))
451
452 ;;; XXX I'd really like to get rid of the x and y slots. They are surely
453 ;;; redundant with the bounding rectangle coordinates.
454 (defclass compound-output-record (basic-output-record)
455 ((x :initarg :x-position
456 :initform 0.0d0
457 :documentation "X-position of the empty record.")
458 (y :initarg :y-position
459 :initform 0.0d0
460 :documentation "Y-position of the empty record.")
461 (in-moving-p :initform nil
462 :documentation "Is set while changing the position."))
463 (:documentation "Implementation class for output records with children."))
464
465 ;;; 16.2.1. The Basic Output Record Protocol
466 (defmethod output-record-position ((record basic-output-record))
467 (bounding-rectangle-position record))
468
469 (defmethod* (setf output-record-position) (nx ny (record basic-output-record))
470 (with-standard-rectangle (x1 y1 x2 y2)
471 record
472 (let ((dx (- nx x1))
473 (dy (- ny y1)))
474 (setf (rectangle-edges* record)
475 (values nx ny (+ x2 dx) (+ y2 dy)))))
476 (values nx ny))
477
478 (defmethod* (setf output-record-position) :around
479 (nx ny (record basic-output-record))
480 (with-bounding-rectangle* (min-x min-y max-x max-y) record
481 (call-next-method)
482 (let ((parent (output-record-parent record)))
483 (when (and parent (not (slot-value parent 'in-moving-p)))
484 (recompute-extent-for-changed-child parent record
485 min-x min-y max-x max-y))))
486 (values nx ny))
487
488 (defmethod* (setf output-record-position)
489 :before (nx ny (record compound-output-record))
490 (with-standard-rectangle* (:x1 x1 :y1 y1)
491 record
492 (letf (((slot-value record 'in-moving-p) t))
493 (let ((dx (- nx x1))
494 (dy (- ny y1)))
495 (map-over-output-records
496 (lambda (child)
497 (multiple-value-bind (x y) (output-record-position child)
498 (setf (output-record-position child)
499 (values (+ x dx) (+ y dy)))))
500 record)))))
501
502 (defmethod output-record-start-cursor-position ((record basic-output-record))
503 (values nil nil))
504
505 (defmethod* (setf output-record-start-cursor-position)
506 (x y (record basic-output-record))
507 (values x y))
508
509 (defmethod output-record-end-cursor-position ((record basic-output-record))
510 (values nil nil))
511
512 (defmethod* (setf output-record-end-cursor-position)
513 (x y (record basic-output-record))
514 (values x y))
515
516 #+cmu
517 (progn
518 ;; Sometimes CMU's PCL fails with forward reference classes, so this
519 ;; is a kludge to keep it happy.
520 ;;
521 ;; This was reported as a bug to cmucl-imp [<E18vKN1-0004DQ-00@saphir.local>]
522 ;;
523 ;; In short it exposes itself when you compile and load into a
524 ;; _virgin_ lisp the following:
525 ;;
526 ;; (defclass foo (bar) ())
527 ;; (defun barz () (make-instance 'foo))
528 ;; (defclass bar () ())
529 ;;
530 ;; --GB 2003-03-18
531 ;;
532 (defclass gs-ink-mixin () ())
533 (defclass gs-clip-mixin () ())
534 (defclass gs-line-style-mixin () ())
535 (defclass gs-text-style-mixin () ()))
536
537 ;;; Humph. It'd be nice to tie this to the actual definition of a
538 ;;; medium. -- moore
539 (defclass complete-medium-state
540 (gs-ink-mixin gs-clip-mixin gs-line-style-mixin gs-text-style-mixin)
541 ())
542
543 (defun replay (record stream &optional region)
544 (stream-close-text-output-record stream)
545 (when (stream-drawing-p stream)
546 (with-cursor-off stream ;;FIXME?
547 (letf (((stream-cursor-position stream) (values 0 0))
548 ((stream-recording-p stream) nil)
549 ;; Is there a better value to bind to baseline?
550 ((slot-value stream 'baseline) (slot-value stream 'baseline)))
551 (with-sheet-medium (medium stream)
552 (let ((medium-state (make-instance 'complete-medium-state
553 :medium medium))
554 (transformation (medium-transformation medium)))
555 (unwind-protect
556 (progn
557 (setf (medium-transformation medium)
558 +identity-transformation+)
559 (replay-output-record record stream region))
560 (setf (medium-transformation medium) transformation)
561 (set-medium-graphics-state medium-state medium))))))))
562
563 (defmethod replay-output-record ((record compound-output-record) stream
564 &optional region (x-offset 0) (y-offset 0))
565 (when (null region)
566 (setq region (or (pane-viewport-region stream) +everywhere+)))
567 (with-drawing-options (stream :clipping-region region)
568 (map-over-output-records-overlapping-region
569 #'replay-output-record record region x-offset y-offset
570 stream region x-offset y-offset)))
571
572 (defmethod output-record-hit-detection-rectangle* ((record output-record))
573 ;; XXX DC
574 (bounding-rectangle* record))
575
576 (defmethod output-record-refined-position-test ((record basic-output-record)
577 x y)
578 (declare (ignore x y))
579 t)
580
581 (defun highlight-output-record-rectangle (record stream state)
582 (with-identity-transformation (stream)
583 (multiple-value-bind (x1 y1 x2 y2)
584 (output-record-hit-detection-rectangle* record)
585 (ecase state
586 (:highlight
587 (draw-rectangle* (sheet-medium stream) x1 y1 (1- x2) (1- y2)
588 :filled nil :ink +foreground-ink+)) ; XXX +FLIPPING-INK+?
589 (:unhighlight
590 ;; FIXME: repaint the hit detection rectangle. It could be bigger than
591 ;;; the bounding rectangle.
592 (repaint-sheet stream record))))))
593
594 ;;; XXX Should this only be defined on recording streams?
595 (defmethod highlight-output-record ((record output-record) stream state)
596 ;; XXX DC
597 ;; XXX Disable recording?
598 (highlight-output-record-rectangle record stream state))
599
600 ;;; 16.2.2. The Output Record "Database" Protocol
601
602 ;; These two aren't in the spec, but are needed to make indirect adding/deleting
603 ;; of GADGET-OUTPUT-RECORDs work:
604
605 (defgeneric note-output-record-lost-sheet (record sheet))
606 (defgeneric note-output-record-got-sheet (record sheet))
607
608 (defmethod note-output-record-lost-sheet ((record output-record) sheet)
609 (declare (ignore record sheet))
610 (values))
611
612 (defmethod note-output-record-lost-sheet :after ((record compound-output-record) sheet)
613 (map-over-output-records #'note-output-record-lost-sheet record 0 0 sheet))
614
615 (defmethod note-output-record-got-sheet ((record output-record) sheet)
616 (declare (ignore record sheet))
617 (values))
618
619 (defmethod note-output-record-got-sheet :after ((record compound-output-record) sheet)
620 (map-over-output-records #'note-output-record-got-sheet record 0 0 sheet))
621
622 (defun find-output-record-sheet (record)
623 "Walks up the parents of RECORD, searching for an output history from which
624 the associated sheet can be determined."
625 (typecase record
626 (stream-output-history-mixin (output-history-stream record))
627 (basic-output-record (find-output-record-sheet (output-record-parent record)))))
628
629 (defmethod output-record-children ((record basic-output-record))
630 nil)
631
632 (defmethod add-output-record (child (record basic-output-record))
633 (declare (ignore child))
634 (error "Cannot add a child to ~S." record))
635
636 (defmethod add-output-record :before (child (record compound-output-record))
637 (let ((parent (output-record-parent child)))
638 (cond (parent
639 (restart-case
640 (error "~S already has a parent ~S." child parent)
641 (delete ()
642 :report "Delete from the old parent."
643 (delete-output-record child parent))))
644 ((eq record child)
645 (error "~S is being added to itself" record))
646 ((eq (output-record-parent record) child)
647 (error "child ~S is being added to its own child ~S"
648 child record)))))
649
650 (defmethod add-output-record :after (child (record compound-output-record))
651 (recompute-extent-for-new-child record child)
652 (when (eq record (output-record-parent child))
653 (let ((sheet (find-output-record-sheet record)))
654 (when sheet (note-output-record-got-sheet child sheet)))))
655
656 (defmethod delete-output-record :before (child (record basic-output-record)
657 &optional (errorp t))
658 (declare (ignore errorp))
659 (let ((sheet (find-output-record-sheet record)))
660 (when sheet
661 (note-output-record-lost-sheet child sheet))))
662
663 (defmethod delete-output-record (child (record basic-output-record)
664 &optional (errorp t))
665 (declare (ignore child))
666 (when errorp (error "Cannot delete a child from ~S." record)))
667
668 (defmethod delete-output-record :after (child (record compound-output-record)
669 &optional (errorp t))
670 (declare (ignore errorp))
671 (with-bounding-rectangle* (x1 y1 x2 y2) child
672 (recompute-extent-for-changed-child record child x1 y1 x2 y2)))
673
674 (defmethod clear-output-record ((record basic-output-record))
675 (error "Cannot clear ~S." record))
676
677 (defmethod clear-output-record :before ((record compound-output-record))
678 (let ((sheet (find-output-record-sheet record)))
679 (when sheet
680 (map-over-output-records #'note-output-record-lost-sheet record 0 0 sheet))))
681
682 (defmethod clear-output-record :after ((record compound-output-record))
683 ;; XXX banish x and y
684 (with-slots (x y)
685 record
686 (setf (rectangle-edges* record) (values x y x y))))
687
688 (defmethod output-record-count ((record basic-output-record))
689 0)
690
691 (defmethod map-over-output-records-1
692 (function (record displayed-output-record) function-args)
693 (declare (ignore function function-args))
694 nil)
695
696 ;;; This needs to work in "most recently added last" order. Is this
697 ;;; implementation right? -- APD, 2002-06-13
698 #+nil
699 (defmethod map-over-output-records
700 (function (record compound-output-record)
701 &optional (x-offset 0) (y-offset 0)
702 &rest function-args)
703 (declare (ignore x-offset y-offset))
704 (map nil (lambda (child) (apply function child function-args))
705 (output-record-children record)))
706
707 (defmethod map-over-output-records-containing-position
708 (function (record displayed-output-record) x y
709 &optional (x-offset 0) (y-offset 0)
710 &rest function-args)
711 (declare (ignore function x y x-offset y-offset function-args))
712 nil)
713
714 ;;; This needs to work in "most recently added first" order. Is this
715 ;;; implementation right? -- APD, 2002-06-13
716 #+nil
717 (defmethod map-over-output-records-containing-position
718 (function (record compound-output-record) x y
719 &optional (x-offset 0) (y-offset 0)
720 &rest function-args)
721 (declare (ignore x-offset y-offset))
722 (map nil
723 (lambda (child)
724 (when (and (multiple-value-bind (min-x min-y max-x max-y)
725 (output-record-hit-detection-rectangle* child)
726 (and (<= min-x x max-x) (<= min-y y max-y)))
727 (output-record-refined-position-test child x y))
728 (apply function child function-args)))
729 (output-record-children record)))
730
731 (defmethod map-over-output-records-overlapping-region
732 (function (record displayed-output-record) region
733 &optional (x-offset 0) (y-offset 0)
734 &rest function-args)
735 (declare (ignore function region x-offset y-offset function-args))
736 nil)
737
738 ;;; This needs to work in "most recently added last" order. Is this
739 ;;; implementation right? -- APD, 2002-06-13
740 #+nil
741 (defmethod map-over-output-records-overlapping-region
742 (function (record compound-output-record) region
743 &optional (x-offset 0) (y-offset 0)
744 &rest function-args)
745 (declare (ignore x-offset y-offset))
746 (map nil
747 (lambda (child) (when (region-intersects-region-p region child)
748 (apply function child function-args)))
749 (output-record-children record)))
750
751 ;;; XXX Dunno about this definition... -- moore
752 (defun null-bounding-rectangle-p (bbox)
753 (with-bounding-rectangle* (x1 y1 x2 y2) bbox
754 (and (zerop x1) (zerop y1)
755 (zerop x2) (zerop y2))))
756
757 ;;; 16.2.3. Output Record Change Notification Protocol
758 (defmethod recompute-extent-for-new-child
759 ((record compound-output-record) child)
760 (unless (null-bounding-rectangle-p child)
761 (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2) record
762 (if (eql 1 (output-record-count record))
763 (setf (rectangle-edges* record) (bounding-rectangle* child))
764 (with-bounding-rectangle* (x1-child y1-child x2-child y2-child)
765 child
766 (setf (rectangle-edges* record)
767 (values (min old-x1 x1-child) (min old-y1 y1-child)
768 (max old-x2 x2-child) (max old-y2 y2-child)))))
769 (let ((parent (output-record-parent record)))
770 (when parent
771 (recompute-extent-for-changed-child
772 parent record old-x1 old-y1 old-x2 old-y2)))))
773 record)
774
775 (defmethod %tree-recompute-extent* ((record compound-output-record))
776 ;; Internal helper function
777 (let ((new-x1 0)
778 (new-y1 0)
779 (new-x2 0)
780 (new-y2 0)
781 (first-time t))
782 (map-over-output-records
783 (lambda (child)
784 (if first-time
785 (progn
786 (multiple-value-setq (new-x1 new-y1 new-x2 new-y2)
787 (bounding-rectangle* child))
788 (setq first-time nil))
789 (with-bounding-rectangle* (cx1 cy1 cx2 cy2) child
790 (minf new-x1 cx1)
791 (minf new-y1 cy1)
792 (maxf new-x2 cx2)
793 (maxf new-y2 cy2))))
794 record)
795 (if first-time
796 ;; XXX banish x y
797 (with-slots (x y) record
798 (values x y x y))
799 (values new-x1 new-y1 new-x2 new-y2))))
800
801 (defgeneric tree-recompute-extent-aux (record))
802
803 (defmethod tree-recompute-extent-aux (record)
804 (bounding-rectangle* record))
805
806 (defmethod tree-recompute-extent-aux ((record compound-output-record))
807 (let ((new-x1 0)
808 (new-y1 0)
809 (new-x2 0)
810 (new-y2 0)
811 (first-time t))
812 (map-over-output-records
813 (lambda (child)
814 (if first-time
815 (progn
816 (multiple-value-setq (new-x1 new-y1 new-x2 new-y2)
817 (tree-recompute-extent-aux child))
818 (setq first-time nil))
819 (multiple-value-bind (cx1 cy1 cx2 cy2)
820 (tree-recompute-extent-aux child)
821 (minf new-x1 cx1)
822 (minf new-y1 cy1)
823 (maxf new-x2 cx2)
824 (maxf new-y2 cy2))))
825 record)
826 (with-slots (x y)
827 record
828 (if first-time ;No children
829 (bounding-rectangle* record)
830 (progn
831 ;; XXX banish x,y
832 (setf x new-x1 y new-y1)
833 (setf (rectangle-edges* record)
834 (values new-x1 new-y1 new-x2 new-y2)))))))
835
836
837 (defmethod recompute-extent-for-changed-child
838 ((record compound-output-record) changed-child
839 old-min-x old-min-y old-max-x old-max-y)
840 (with-bounding-rectangle* (ox1 oy1 ox2 oy2) record
841 (with-bounding-rectangle* (cx1 cy1 cx2 cy2) changed-child
842 ;; If record is currently empty, use the child's bbox directly. Else..
843 ;; Does the new rectangle of the child contain the original rectangle?
844 ;; If so, we can use min/max to grow record's current rectangle.
845 ;; If not, the child has shrunk, and we need to fully recompute.
846 (multiple-value-bind (nx1 ny1 nx2 ny2)
847 (cond ((not (output-record-parent changed-child))
848 ;; The child has been deleted; who knows what the
849 ;; new bounding box might be.
850 (%tree-recompute-extent* record))
851 ((eql (output-record-count record) 1)
852 (values cx1 cy1 cx2 cy2))
853 #+nil((null-bounding-rectangle-p record)
854 (%tree-recompute-extent* record))
855 #+nil((null-bounding-rectangle-p changed-child)
856 (values ox1 oy1 ox2 oy2))
857 ((and (<= cx1 old-min-x) (<= cy1 old-min-y)
858 (>= cx2 old-max-x) (>= cy2 old-max-y))
859 (values (min cx1 ox1) (min cy1 oy1)
860 (max cx2 ox2) (max cy2 oy2)))
861 (T (%tree-recompute-extent* record)))
862 ;; XXX banish x, y
863 (with-slots (x y)
864 record
865 (setf x nx1 y ny1)
866 (setf (rectangle-edges* record) (values nx1 ny1 nx2 ny2))
867 (let ((parent (output-record-parent record)))
868 (unless (or (null parent)
869 (and (= nx1 ox1) (= ny1 oy1)
870 (= nx2 ox2) (= nx2 oy2)))
871 (recompute-extent-for-changed-child parent record
872 ox1 oy1 ox2 oy2)))))))
873 record)
874
875 ;; There was once an :around method on recompute-extent-for-changed-child here,
876 ;; but I've eliminated it. Its function was to notify the parent OR in case
877 ;; the bounding rect here changed - I've merged this into the above method.
878 ;; --Hefner, 8/7/02
879
880 (defmethod tree-recompute-extent ((record compound-output-record))
881 (tree-recompute-extent-aux record)
882 record)
883
884 (defmethod tree-recompute-extent :around ((record compound-output-record))
885 (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2)
886 record
887 (call-next-method)
888 (with-bounding-rectangle* (x1 y1 x2 y2)
889 record
890 (let ((parent (output-record-parent record)))
891 (when (and parent
892 (not (and (= old-x1 x1)
893 (= old-y1 y1)
894 (= old-x2 x2)
895 (= old-y2 y2))))
896 (recompute-extent-for-changed-child parent record
897 old-x1 old-y1
898 old-x2 old-y2)))))
899 record)
900
901 ;;; 16.3.1. Standard output record classes
902
903 (defclass standard-sequence-output-record (compound-output-record)
904 ((children :initform (make-array 8 :adjustable t :fill-pointer 0)
905 :reader output-record-children)))
906
907 (defmethod add-output-record (child (record standard-sequence-output-record))
908 (vector-push-extend child (output-record-children record))
909 (setf (output-record-parent child) record))
910
911 (defmethod delete-output-record (child (record standard-sequence-output-record)
912 &optional (errorp t))
913 (with-slots (children) record
914 (let ((pos (position child children :test #'eq)))
915 (if (null pos)
916 (when errorp
917 (error "~S is not a child of ~S" child record))
918 (progn
919 (setq children (replace children children
920 :start1 pos
921 :start2 (1+ pos)))
922 (decf (fill-pointer children))
923 (setf (output-record-parent child) nil))))))
924
925 (defmethod clear-output-record ((record standard-sequence-output-record))
926 (let ((children (output-record-children record)))
927 (map 'nil (lambda (child) (setf (output-record-parent child) nil))
928 children)
929 (fill children nil)
930 (setf (fill-pointer children) 0)))
931
932 (defmethod output-record-count ((record standard-sequence-output-record))
933 (length (output-record-children record)))
934
935 (defmethod map-over-output-records-1
936 (function (record standard-sequence-output-record) function-args)
937 "Applies FUNCTION to all children in the order they were added."
938 (declare (ignore x-offset y-offset))
939 (if function-args
940 (loop with children = (output-record-children record)
941 for child across children
942 do (apply function child function-args))
943 (loop with children = (output-record-children record)
944 for child across children
945 do (funcall function child))))
946
947
948 (defmethod map-over-output-records-containing-position
949 (function (record standard-sequence-output-record) x y
950 &optional (x-offset 0) (y-offset 0)
951 &rest function-args)
952 "Applies FUNCTION to children, containing (X,Y), in the reversed
953 order they were added."
954 (declare (ignore x-offset y-offset))
955 (loop with children = (output-record-children record)
956 for i from (1- (length children)) downto 0
957 for child = (aref children i)
958 when (and (multiple-value-bind (min-x min-y max-x max-y)
959 (output-record-hit-detection-rectangle* child)
960 (and (<= min-x x max-x) (<= min-y y max-y)))
961 (output-record-refined-position-test child x y))
962 do (apply function child function-args)))
963
964 (defmethod map-over-output-records-overlapping-region
965 (function (record standard-sequence-output-record) region
966 &optional (x-offset 0) (y-offset 0)
967 &rest function-args)
968 "Applies FUNCTION to children, overlapping REGION, in the order they
969 were added."
970 (declare (ignore x-offset y-offset))
971 (loop with children = (output-record-children record)
972 for child across children
973 when (region-intersects-region-p region child)
974 do (apply function child function-args)))
975
976 ;;; XXX bogus for now.
977 (defclass standard-tree-output-record (standard-sequence-output-record)
978 (
979 ))
980
981 (defmethod match-output-records ((record t) &rest args)
982 (apply #'match-output-records-1 record args))
983
984 ;;; Factor out the graphics state portions of the output records so
985 ;;; they can be manipulated seperately e.g., by incremental
986 ;;; display. The individual slots of a graphics state are factored into mixin
987 ;;; classes so that each output record can capture only the state that it needs.
988 ;;; -- moore
989
990 ;;; It would be appealing to define a setf method, e.g. (setf
991 ;;; medium-graphics-state), for setting a medium's state from a graphics state
992 ;;; object, but that would require us to define a medium-graphics-state reader
993 ;;; that would cons a state object. I don't want to do that.
994
995 (defclass graphics-state ()
996 ()
997 (:documentation "Stores those parts of the medium/stream graphics state
998 that need to be restored when drawing an output record"))
999
1000 (defgeneric set-medium-graphics-state (state medium)
1001 (:documentation "Sets the MEDIUM graphics state from STATE"))
1002
1003 (defmethod set-medium-graphics-state (state medium)
1004 (declare (ignore medium))
1005 state)
1006
1007 (defmethod set-medium-graphics-state (state (stream output-recording-stream))
1008 (with-sheet-medium (medium stream)
1009 (set-medium-graphics-state state medium)))
1010
1011 (defclass gs-ink-mixin (graphics-state)
1012 ((ink :initarg :ink :accessor graphics-state-ink)))
1013
1014 (defmethod initialize-instance :after ((obj gs-ink-mixin)
1015 &key (stream nil)
1016 (medium (when stream
1017 (sheet-medium stream))))
1018 (when (and medium (not (slot-boundp obj 'ink)))
1019 (setf (slot-value obj 'ink) (medium-ink medium))))
1020
1021 (defmethod set-medium-graphics-state :after ((state gs-ink-mixin) medium)
1022 (setf (medium-ink medium) (graphics-state-ink state)))
1023
1024 (defrecord-predicate gs-ink-mixin (ink)
1025 (if-supplied (ink)
1026 (design-equalp (slot-value record 'ink) ink)))
1027
1028 (defclass gs-clip-mixin (graphics-state)
1029 ((clip :initarg :clipping-region :accessor graphics-state-clip
1030 :documentation "Clipping region in stream coordinates.")))
1031
1032
1033 (defmethod initialize-instance :after ((obj gs-clip-mixin)
1034 &key (stream nil)
1035 (medium (when stream
1036 (sheet-medium stream))))
1037 (when medium
1038 (with-slots (clip)
1039 obj
1040 (let ((clip-region (if (slot-boundp obj 'clip)
1041 (region-intersection (medium-clipping-region
1042 medium)
1043 clip)
1044 (medium-clipping-region medium))))
1045 (setq clip (transform-region (medium-transformation medium)
1046 clip-region))))))
1047
1048 (defmethod set-medium-graphics-state :after ((state gs-clip-mixin) medium)
1049 ;;
1050 ;; This definition is kind of wrong. When output records are about to
1051 ;; be replayed only a certain region of the stream should be affected.[1]
1052 ;; Therefore I disabled this code, since this way only breaks the
1053 ;; [not very frequent case] that the output record actually contains
1054 ;; a clipping region different from +everywhere+, while having it in
1055 ;; breaks redisplay of streams in just about every case.
1056 ;;
1057 ;; Most notably Closure is affected by this, as it does the equivalent of
1058 ;; (draw-rectangle* medium 0 0 800 200 :ink +white+ :filled t)
1059 ;; (draw-text* medium "Hello" 100 100)
1060 ;;
1061 ;; Having this code in a redisplay on the region
1062 ;; (make-rectangle* 0 0 50 50) fills the drawing pane with a white
1063 ;; rectangle obscuring the text.
1064 ;;
1065 ;; [1] it is of course debatable where this extra clipping because
1066 ;; of redisplay should come from. Should replay-output-record set it
1067 ;; up? Should handle-repaint do so?
1068 ;;
1069 ;; --GB 2003-03-14
1070 (declare (ignore medium))
1071 #+nil
1072 (setf (medium-clipping-region medium) (graphics-state-clip state)))
1073
1074 (defrecord-predicate gs-clip-mixin ((:clipping-region clip))
1075 (if-supplied (clip)
1076 (region-equal (slot-value record 'clip) clip)))
1077
1078 ;;; 16.3.2. Graphics Displayed Output Records
1079 (defclass standard-displayed-output-record (gs-clip-mixin gs-ink-mixin
1080 basic-output-record
1081 displayed-output-record)
1082 ((ink :reader displayed-output-record-ink)
1083 (stream :initarg :stream))
1084 (:documentation "Implementation class for DISPLAYED-OUTPUT-RECORD.")
1085 (:default-initargs :stream nil))
1086
1087 (defclass gs-line-style-mixin (graphics-state)
1088 ((line-style :initarg :line-style :accessor graphics-state-line-style)))
1089
1090 (defmethod initialize-instance :after ((obj gs-line-style-mixin)
1091 &key (stream nil)
1092 (medium (when stream
1093 (sheet-medium stream))))
1094 (when medium
1095 (unless (slot-boundp obj 'line-style)
1096 (setf (slot-value obj 'line-style) (medium-line-style medium)))))
1097
1098 (defmethod set-medium-graphics-state :after ((state gs-line-style-mixin) medium)
1099 (setf (medium-line-style medium) (graphics-state-line-style state)))
1100
1101 (defrecord-predicate gs-line-style-mixin (line-style)
1102 (if-supplied (line-style)
1103 (line-style-equalp (slot-value record 'line-style) line-style)))
1104
1105 (defgeneric graphics-state-line-style-border (record medium)
1106 (:method ((record gs-line-style-mixin) medium)
1107 (/ (line-style-effective-thickness (graphics-state-line-style record)
1108 medium)
1109 2)))
1110
1111 (defclass gs-text-style-mixin (graphics-state)
1112 ((text-style :initarg :text-style :accessor graphics-state-text-style)))
1113
1114 (defmethod initialize-instance :after ((obj gs-text-style-mixin)
1115 &key (stream nil)
1116 (medium (when stream
1117 (sheet-medium stream))))
1118 (when medium
1119 (unless (slot-boundp obj 'text-style)
1120 (setf (slot-value obj 'text-style) (medium-text-style medium)))))
1121
1122 (defmethod set-medium-graphics-state :after ((state gs-text-style-mixin) medium)
1123 (setf (medium-text-style medium) (graphics-state-text-style state)))
1124
1125 (defrecord-predicate gs-text-style-mixin (text-style)
1126 (if-supplied (text-style)
1127 (text-style-equalp (slot-value record 'text-style) text-style)))
1128
1129 (defclass standard-graphics-displayed-output-record
1130 (standard-displayed-output-record
1131 graphics-displayed-output-record)
1132 ())
1133
1134 (defmethod match-output-records-1 and
1135 ((record standard-displayed-output-record)
1136 &key (x1 nil x1-p) (y1 nil y1-p)
1137 (x2 nil x2-p) (y2 nil y2-p)
1138 (bounding-rectangle nil bounding-rectangle-p))
1139 (if bounding-rectangle-p
1140 (region-equal record bounding-rectangle)
1141 (multiple-value-bind (my-x1 my-y1 my-x2 my-y2)
1142 (bounding-rectangle* record)
1143 (macrolet ((coordinate=-or-lose (key mine)
1144 `(if (typep ,key 'coordinate)
1145 (coordinate= ,mine ,key)
1146 (error 'type-error
1147 :datum ,key
1148 :expected-type 'coordinate))))
1149 (and (or (null x1-p)
1150 (coordinate=-or-lose x1 my-x1))
1151 (or (null y1-p)
1152 (coordinate=-or-lose y1 my-y1))
1153 (or (null x2-p)
1154 (coordinate=-or-lose x2 my-x2))
1155 (or (null y2-p)
1156 (coordinate=-or-lose y2 my-y2)))))))
1157
1158 (defmethod output-record-equal and ((record standard-displayed-output-record)
1159 (record2 standard-displayed-output-record))
1160 (region-equal record record2))
1161
1162 ;;; This is an around method so that more specific before methods can be
1163 ;;; defined for the various mixin classes, that modify the state after it has
1164 ;;; been set in the graphics state.
1165
1166 (defmethod replay-output-record :around
1167 ((record standard-displayed-output-record) stream
1168 &optional region x-offset y-offset)
1169 (declare (ignore region x-offset y-offset))
1170 (set-medium-graphics-state record stream)
1171 (call-next-method))
1172
1173 (defclass coord-seq-mixin ()
1174 ((coord-seq :accessor coord-seq :initarg :coord-seq))
1175 (:documentation "Mixin class that implements methods for records that contain
1176 sequences of coordinates."))
1177
1178 (defun coord-seq-bounds (coord-seq border)
1179 (setf border (ceiling border))
1180 (let* ((min-x (elt coord-seq 0))
1181 (min-y (elt coord-seq 1))
1182 (max-x min-x)
1183 (max-y min-y))
1184 (do-sequence ((x y) coord-seq)
1185 (minf min-x x)
1186 (minf min-y y)
1187 (maxf max-x x)
1188 (maxf max-y y))
1189 (values (floor (- min-x border))
1190 (floor (- min-y border))
1191 (ceiling (+ max-x border))
1192 (ceiling (+ max-y border)))))
1193
1194 ;;; record must be a standard-rectangle
1195
1196 (defmethod* (setf output-record-position) :around
1197 (nx ny (record coord-seq-mixin))
1198 (with-standard-rectangle* (:x1 x1 :y1 y1)
1199 record
1200 (let ((dx (- nx x1))
1201 (dy (- ny y1))
1202 (coords (slot-value record 'coord-seq)))
1203 (multiple-value-prog1
1204 (call-next-method)
1205 (loop for i from 0 below (length coords) by 2
1206 do (progn
1207 (incf (aref coords i) dx)
1208 (incf (aref coords (1+ i)) dy)))))))
1209
1210 (defmethod match-output-records-1 and ((record coord-seq-mixin)
1211 &key (coord-seq nil coord-seq-p))
1212 (or (null coord-seq-p)
1213 (let* ((my-coord-seq (slot-value record 'coord-seq))
1214 (len (length my-coord-seq)))
1215 (and (eql len (length coord-seq))
1216 (loop for elt1 across my-coord-seq
1217 for elt2 across coord-seq
1218 always (coordinate= elt1 elt2))))))
1219
1220 (defmacro generate-medium-recording-body (class-name method-name args)
1221 (let ((arg-list (loop for arg in args
1222 nconc `(,(intern (symbol-name arg) :keyword) ,arg))))
1223 `(with-sheet-medium (medium stream)
1224 (when (stream-recording-p stream)
1225 (let ((record
1226 ;; Hack: the coord-seq-mixin makes the assumption that, well
1227 ;; coord-seq is a coord-vector. So we morph a possible
1228 ;; coord-seq argument into a vector.
1229 (let (,@(when (member 'coord-seq args)
1230 `((coord-seq
1231 (if (vectorp coord-seq)
1232 coord-seq
1233 (coerce coord-seq 'vector))))))
1234 (make-instance ',class-name
1235 :stream stream
1236 ,@arg-list))))
1237 (stream-add-output-record stream record)))
1238 (when (stream-drawing-p stream)
1239 (,method-name medium ,@args)))))
1240
1241 ;; DEF-GRECORDING: This is the central interface through which recording
1242 ;; is implemented for drawing functions. The body provided is used to
1243 ;; compute the bounding rectangle of the rendered output. DEF-GRECORDING
1244 ;; will define a class for the output record, with slots corresponding to the
1245 ;; drawing function arguments. It also defines an INITIALIZE-INSTANCE method
1246 ;; computing the bounding rectangle of the record. It defines a method for
1247 ;; the medium drawing function specialized on output-recording-stream, which
1248 ;; is responsible for creating the output record and adding it to the stream
1249 ;; history. It also defines a REPLAY-OUTPUT-RECORD method, which calls the
1250 ;; medium drawing function based on the recorded slots.
1251
1252 (defmacro def-grecording (name ((&rest mixins) &rest args)
1253 (&key (class t)
1254 (medium-fn t)
1255 (replay-fn t)) &body body)
1256 (let ((method-name (symbol-concat '#:medium- name '*))
1257 (class-name (symbol-concat name '#:-output-record))
1258 (medium (gensym "MEDIUM"))
1259 (class-vars `((stream :initarg :stream)
1260 ,@(loop for arg in args
1261 collect `(,arg
1262 :initarg ,(intern (symbol-name arg)
1263 :keyword))))))
1264 `(progn
1265 ,@(when class
1266 `((defclass ,class-name (,@mixins standard-graphics-displayed-output-record)
1267 ,class-vars)
1268 (defmethod initialize-instance :after ((graphic ,class-name)
1269 &key)
1270 (declare (ignore args))
1271 (with-slots (stream ink clipping-region
1272 line-style text-style ,@args)
1273 graphic
1274 (let* ((medium (sheet-medium stream)))
1275 (setf (rectangle-edges* graphic)
1276 (progn ,@body)))))))
1277 ,(when medium-fn
1278 `(defmethod ,method-name :around ((stream output-recording-stream) ,@args)
1279 ;; XXX STANDARD-OUTPUT-RECORDING-STREAM ^?
1280 (generate-medium-recording-body ,class-name ,method-name ,args)))
1281 ,(when replay-fn
1282 `(defmethod replay-output-record ((record ,class-name) stream
1283 &optional (region +everywhere+)
1284 (x-offset 0) (y-offset 0))
1285 (declare (ignore x-offset y-offset region))
1286 (with-slots (,@args) record
1287 (let ((,medium (sheet-medium stream))
1288 ;; is sheet a sheet-with-medium-mixin? --GB
1289 )
1290 ;; Graphics state is set up in :around method.
1291 (,method-name ,medium ,@args))))))))
1292
1293 (def-grecording draw-point ((gs-line-style-mixin) point-x point-y) ()
1294 (let ((border (graphics-state-line-style-border graphic medium)))
1295 (with-transformed-position ((medium-transformation medium) point-x point-y)
1296 (setf (slot-value graphic 'point-x) point-x
1297 (slot-value graphic 'point-y) point-y)
1298 (values (- point-x border)
1299 (- point-y border)
1300 (+ point-x border)
1301 (+ point-y border)))))
1302
1303 (defmethod* (setf output-record-position) :around
1304 (nx ny (record draw-point-output-record))
1305 (with-standard-rectangle* (:x1 x1 :y1 y1)
1306 record
1307 (with-slots (point-x point-y)
1308 record
1309 (let ((dx (- nx x1))
1310 (dy (- ny y1)))
1311 (multiple-value-prog1
1312 (call-next-method)
1313 (incf point-x dx)
1314 (incf point-y dy))))))
1315
1316 (defrecord-predicate draw-point-output-record (point-x point-y)
1317 (and (if-supplied (point-x coordinate)
1318 (coordinate= (slot-value record 'point-x) point-x))
1319 (if-supplied (point-y coordinate)
1320 (coordinate= (slot-value record 'point-y) point-y))))
1321
1322 (def-grecording draw-points ((coord-seq-mixin gs-line-style-mixin) coord-seq) ()
1323 (let ((transformed-coord-seq (transform-positions (medium-transformation medium) coord-seq))
1324 (border (graphics-state-line-style-border graphic medium)))
1325 (setf (slot-value graphic 'coord-seq) transformed-coord-seq)
1326 (coord-seq-bounds transformed-coord-seq border)))
1327
1328 (def-grecording draw-line ((gs-line-style-mixin)
1329 point-x1 point-y1 point-x2 point-y2) ()
1330 (let ((transform (medium-transformation medium))
1331 (border (graphics-state-line-style-border graphic medium)))
1332 (with-transformed-position (transform point-x1 point-y1)
1333 (with-transformed-position (transform point-x2 point-y2)
1334 (setf (slot-value graphic 'point-x1) point-x1
1335 (slot-value graphic 'point-y1) point-y1
1336 (slot-value graphic 'point-x2) point-x2
1337 (slot-value graphic 'point-y2) point-y2)
1338 (values (- (min point-x1 point-x2) border)
1339 (- (min point-y1 point-y2) border)
1340 (+ (max point-x1 point-x2) border)
1341 (+ (max point-y1 point-y2) border))))))
1342
1343 (defmethod* (setf output-record-position) :around
1344 (nx ny (record draw-line-output-record))
1345 (with-standard-rectangle* (:x1 x1 :y1 y1)
1346 record
1347 (with-slots (point-x1 point-y1 point-x2 point-y2)
1348 record
1349 (let ((dx (- nx x1))
1350 (dy (- ny y1)))
1351 (multiple-value-prog1
1352 (call-next-method)
1353 (incf point-x1 dx)
1354 (incf point-y1 dy)
1355 (incf point-x2 dx)
1356 (incf point-y2 dy))))))
1357
1358 (defrecord-predicate draw-line-output-record (point-x1 point-y1
1359 point-x2 point-y2)
1360 (and (if-supplied (point-x1 coordinate)
1361 (coordinate= (slot-value record 'point-x1) point-x1))
1362 (if-supplied (point-y1 coordinate)
1363 (coordinate= (slot-value record 'point-y1) point-y1))
1364 (if-supplied (point-x2 coordinate)
1365 (coordinate= (slot-value record 'point-x2) point-x2))
1366 (if-supplied (point-y2 coordinate)
1367 (coordinate= (slot-value record 'point-y2) point-y2))))
1368
1369 (def-grecording draw-lines ((coord-seq-mixin gs-line-style-mixin) coord-seq) ()
1370 (let ((transformed-coord-seq (transform-positions (medium-transformation medium) coord-seq))
1371 (border (graphics-state-line-style-border graphic medium)))
1372 (setf coord-seq transformed-coord-seq)
1373 (coord-seq-bounds transformed-coord-seq border)))
1374
1375 ;;; (setf output-record-position) and predicates for draw-lines-output-record
1376 ;;; are taken care of by methods on superclasses.
1377
1378 ;;; Helper function
1379 (defun normalize-coords (dx dy &optional unit)
1380 (let ((norm (sqrt (+ (* dx dx) (* dy dy)))))
1381 (cond ((= norm 0.0d0)
1382 (values 0.0d0 0.0d0))
1383 (unit
1384 (let ((scale (/ unit norm)))
1385 (values (* dx scale) (* dy scale))))
1386 (t (values (/ dx norm) (/ dy norm))))))
1387
1388 (defun polygon-record-bounding-rectangle
1389 (coord-seq closed filled line-style border miter-limit)
1390 (cond (filled
1391 (coord-seq-bounds coord-seq 0))
1392 ((eq (line-style-joint-shape line-style) :round)
1393 (coord-seq-bounds coord-seq border))
1394 (t (let* ((x1 (svref coord-seq 0))
1395 (y1 (svref coord-seq 1))
1396 (min-x x1)
1397 (min-y y1)
1398 (max-x x1)
1399 (max-y y1)
1400 (len (length coord-seq)))
1401 (unless closed
1402 (setq min-x (- x1 border) min-y (- y1 border)
1403 max-x (+ x1 border) max-y (+ y1 border)))
1404 ;; Setup for iterating over the coordinate vector. If the polygon
1405 ;; is closed deal with the extra segment.
1406 (multiple-value-bind (initial-xp initial-yp
1407 final-xn final-yn
1408 initial-index final-index)
1409 (if closed
1410 (values (svref coord-seq (- len 2))
1411 (svref coord-seq (- len 1))
1412 x1 y1
1413 0 (- len 2))
1414 (values x1 y1
1415 (svref coord-seq (- len 2))
1416 (svref coord-seq (- len 1))
1417 2 (- len 4)))
1418 (ecase (line-style-joint-shape line-style)
1419 (:miter
1420 ;;FIXME: Remove successive positively proportional segments
1421 (loop with sin-limit = (sin (* 0.5 miter-limit))
1422 and xn and yn
1423 for i from initial-index to final-index by 2
1424 for xp = initial-xp then x
1425 for yp = initial-yp then y
1426 for x = (svref coord-seq i)
1427 for y = (svref coord-seq (1+ i))
1428 do (setf (values xn yn)
1429 (if (eql i final-index)
1430 (values final-xn final-yn)
1431 (values (svref coord-seq (+ i 2))
1432 (svref coord-seq (+ i
1433 3)))))
1434 (multiple-value-bind (ex1 ey1)
1435 (normalize-coords (- x xp) (- y yp))
1436 (multiple-value-bind (ex2 ey2)
1437 (normalize-coords (- x xn) (- y yn))
1438 (let* ((cos-a (+ (* ex1 ex2) (* ey1 ey2)))
1439 (sin-a/2 (sqrt (* 0.5 (- 1.0 cos-a)))))
1440 (if (< sin-a/2 sin-limit)
1441 (let ((nx (* border
1442 (max (abs ey1) (abs ey2))))
1443 (ny (* border
1444 (max (abs ex1) (abs ex2)))))
1445 (minf min-x (- x nx))
1446 (minf min-y (- y ny))
1447 (maxf max-x (+ x nx))
1448 (maxf max-y (+ y ny)))
1449 (let ((length (/ border sin-a/2)))
1450 (multiple-value-bind (dx dy)
1451 (normalize-coords (+ ex1 ex2)
1452 (+ ey1 ey2)
1453 length)
1454 (minf min-x (+ x dx))
1455 (minf min-y (+ y dy))
1456 (maxf max-x (+ x dx))
1457 (maxf max-y (+ y dy))))))))))
1458 ((:bevel :none)
1459 (loop with xn and yn
1460 for i from initial-index to final-index by 2
1461 for xp = initial-xp then x
1462 for yp = initial-yp then y
1463 for x = (svref coord-seq i)
1464 for y = (svref coord-seq (1+ i))
1465 do (setf (values xn yn)
1466 (if (eql i final-index)
1467 (values final-xn final-yn)
1468 (values (svref coord-seq (+ i 2))
1469 (svref coord-seq (+ i
1470 3)))))
1471 (multiple-value-bind (ex1 ey1)
1472 (normalize-coords (- x xp) (- y yp))
1473 (multiple-value-bind (ex2 ey2)
1474 (normalize-coords (- x xn) (- y yn))
1475 (let ((nx (* border (max (abs ey1) (abs ey2))))
1476 (ny (* border (max (abs ex1) (abs ex2)))))
1477 (minf min-x (- x nx))
1478 (minf min-y (- y ny))
1479 (maxf max-x (+ x nx))
1480 (maxf max-y (+ y ny))))))))
1481 (unless closed
1482 (multiple-value-bind (x y)
1483 (values (svref coord-seq final-index)
1484 (svref coord-seq (1+ final-index)))
1485 (minf min-x (- x border))
1486 (minf min-y (- y border))
1487 (maxf max-x (+ x border))
1488 (maxf max-y (+ y border)))))
1489 (values min-x min-y max-x max-y)))))
1490
1491 (def-grecording draw-polygon ((coord-seq-mixin gs-line-style-mixin)
1492 coord-seq closed filled) ()
1493 (let ((transformed-coord-seq (transform-positions (medium-transformation medium) coord-seq))
1494 (border (graphics-state-line-style-border graphic medium)))
1495 (setf coord-seq transformed-coord-seq)
1496 (polygon-record-bounding-rectangle transformed-coord-seq
1497 closed filled line-style border
1498 (medium-miter-limit medium))))
1499
1500 (defrecord-predicate draw-polygon-output-record (closed filled)
1501 (and (if-supplied (closed)
1502 (eql (slot-value record 'closed) closed))
1503 (if-supplied (filled)
1504 (eql (slot-value record 'filled) filled))))
1505
1506 (def-grecording draw-rectangle ((gs-line-style-mixin)
1507 left top right bottom filled) (:medium-fn nil)
1508 (let* ((transform (medium-transformation medium))
1509 (border (graphics-state-line-style-border graphic medium))
1510 (pre-coords (expand-rectangle-coords left top right bottom))
1511 (coords (transform-positions transform pre-coords)))
1512 (setf (values left top) (transform-position transform left top))
1513 (setf (values right bottom) (transform-position transform right bottom))
1514 (polygon-record-bounding-rectangle coords t filled line-style border
1515 (medium-miter-limit medium))))
1516
1517 (defmethod medium-draw-rectangle* :around ((stream output-recording-stream) left top right bottom filled)
1518 (let ((tr (medium-transformation stream)))
1519 (if (rectilinear-transformation-p tr)
1520 (generate-medium-recording-body draw-rectangle-output-record
1521 medium-draw-rectangle*
1522 (left top right bottom filled))
1523 (medium-draw-polygon* stream
1524 (expand-rectangle-coords left top right bottom)
1525 t
1526 filled))))
1527
1528 (defmethod* (setf output-record-position) :around
1529 (nx ny (record draw-rectangle-output-record))
1530 (with-standard-rectangle* (:x1 x1 :y1 y1)
1531 record
1532 (with-slots (left top right bottom)
1533 record
1534 (let ((dx (- nx x1))
1535 (dy (- ny y1)))
1536 (multiple-value-prog1
1537 (call-next-method)
1538 (incf left dx)
1539 (incf top dy)
1540 (incf right dx)
1541 (incf bottom dy))))))
1542
1543 (defrecord-predicate draw-rectangle-output-record (left top right bottom filled)
1544 (and (if-supplied (left coordinate)
1545 (coordinate= (slot-value record 'left) left))
1546 (if-supplied (top coordinate)
1547 (coordinate= (slot-value record 'top) top))
1548 (if-supplied (right coordinate)
1549 (coordinate= (slot-value record 'right) right))
1550 (if-supplied (bottom coordinate)
1551 (coordinate= (slot-value record 'bottom) bottom))
1552 (if-supplied (filled)
1553 (eql (slot-value record 'filled) filled))))
1554
1555 (def-grecording draw-ellipse ((gs-line-style-mixin)
1556 center-x center-y
1557 radius-1-dx radius-1-dy radius-2-dx radius-2-dy
1558 start-angle end-angle filled) ()
1559 (let ((transform (medium-transformation medium)))
1560 (setf (values center-x center-y)
1561 (transform-position transform center-x center-y))
1562 (setf (values radius-1-dx radius-1-dy)
1563 (transform-distance transform radius-1-dx radius-1-dy))
1564 (setf (values radius-2-dx radius-2-dy)
1565 (transform-distance transform radius-2-dx radius-2-dy))
1566 ;; I think this should be untransform-angle below, as the ellipse angles
1567 ;; go counter-clockwise in screen coordinates, whereas our transformations
1568 ;; rotate clockwise in the default coorinate system.. this is quite possibly
1569 ;; wrong depending on how one reads the spec, but just reversing it here
1570 ;; will break other things. -Hefner
1571 (setf start-angle (untransform-angle transform start-angle))
1572 (setf end-angle (untransform-angle transform end-angle))
1573 (when (reflection-transformation-p transform)
1574 (rotatef start-angle end-angle))
1575 (multiple-value-bind (min-x min-y max-x max-y)
1576 (bounding-rectangle* (make-ellipse* center-x center-y
1577 radius-1-dx radius-1-dy
1578 radius-2-dx radius-2-dy
1579 :start-angle start-angle
1580 :end-angle end-angle))
1581 (if filled
1582 (values min-x min-y max-x max-y)
1583 (let ((border (graphics-state-line-style-border graphic medium)))
1584 (values (- min-x border)
1585 (- min-y border)
1586 (+ max-x border)
1587 (+ max-y border)))))))
1588
1589 (defmethod* (setf output-record-position) :around
1590 (nx ny (record draw-ellipse-output-record))
1591 (with-standard-rectangle* (:x1 x1 :y1 y1)
1592 record
1593 (with-slots (center-x center-y)
1594 record
1595 (let ((dx (- nx x1))
1596 (dy (- ny y1)))
1597 (multiple-value-prog1
1598 (call-next-method)
1599 (incf center-x dx)
1600 (incf center-y dy))))))
1601
1602 (defrecord-predicate draw-ellipse-output-record (center-x center-y)
1603 (and (if-supplied (center-x coordinate)
1604 (coordinate= (slot-value record 'center-x) center-x))
1605 (if-supplied (center-y coordinate)
1606 (coordinate= (slot-value record 'center-y) center-y))))
1607
1608 ;;;; Patterns
1609
1610 ;;; The Spec says that "transformation only affects the position at
1611 ;;; which the pattern is drawn, not the pattern itself"
1612 (def-grecording draw-pattern (() pattern x y) ()
1613 (let ((width (pattern-width pattern))
1614 (height (pattern-height pattern))
1615 (transform (medium-transformation medium)))
1616 (setf (values x y) (transform-position transform x y))
1617 (values x y (+ x width) (+ y height))))
1618
1619 (defmethod* (setf output-record-position) :around
1620 (nx ny (record draw-pattern-output-record))
1621 (with-standard-rectangle* (:x1 x1 :y1 y1)
1622 record
1623 (with-slots (x y)
1624 record
1625 (let ((dx (- nx x1))
1626 (dy (- ny y1)))
1627 (multiple-value-prog1
1628 (call-next-method)
1629 (incf x dx)
1630 (incf y dy))))))
1631
1632 (defrecord-predicate draw-pattern-output-record (x y pattern)
1633 ;; ### I am not so sure about the correct usage of DEFRECORD-PREDICATE
1634 ;; --GB 2003-08-15
1635 (and (if-supplied (x coordinate)
1636 (coordinate= (slot-value record 'x) x))
1637 (if-supplied (y coordinate)
1638 (coordinate= (slot-value record 'y) y))
1639 (if-supplied (pattern pattern)
1640 (eq (slot-value record 'pattern) pattern))))
1641
1642 ;;;; Text
1643
1644 (def-grecording draw-text ((gs-text-style-mixin) string point-x point-y start end
1645 align-x align-y toward-x toward-y transform-glyphs) ()
1646 ;; FIXME!!! Text direction.
1647 ;; Multiple lines?
1648 (let* ((text-style (graphics-state-text-style graphic))
1649 (width (if (characterp string)
1650 (stream-character-width stream string :text-style text-style)
1651 (stream-string-width stream string
1652 :start start :end end
1653 :text-style text-style)) )
1654 (ascent (text-style-ascent text-style (sheet-medium stream)))
1655 (descent (text-style-descent text-style (sheet-medium stream)))
1656 (height (+ ascent descent))
1657 (transform (medium-transformation medium))
1658 left top right bottom)
1659 (setf (values point-x point-y)
1660 (transform-position transform point-x point-y))
1661 (ecase align-x
1662 (:left (setq left point-x
1663 right (+ point-x width)))
1664 (:right (setq left (- point-x width)
1665 right point-x))
1666 (:center (setq left (- point-x (round width 2))
1667 right (+ point-x (round width 2)))))
1668 (ecase align-y
1669 (:baseline (setq top (- point-y ascent)
1670 bottom (+ point-y descent)))
1671 (:top (setq top point-y
1672 bottom (+ point-y height)))
1673 (:bottom (setq top (- point-y height)
1674 bottom point-y))
1675 (:center (setq top (- point-y (floor height 2))
1676 bottom (+ point-y (ceiling height 2)))))
1677 (values left top right bottom)))
1678
1679 (defmethod* (setf output-record-position) :around
1680 (nx ny (record draw-text-output-record))
1681 (with-standard-rectangle* (:x1 x1 :y1 y1)
1682 record
1683 (with-slots (point-x point-y toward-x toward-y)
1684 record
1685 (let ((dx (- nx x1))
1686 (dy (- ny y1)))
1687 (multiple-value-prog1
1688 (call-next-method)
1689 (incf point-x dx)
1690 (incf point-y dy)
1691 (incf toward-x dx)
1692 (incf toward-y dy))))))
1693
1694 (defrecord-predicate draw-text-output-record
1695 (string start end point-x point-y align-x align-y toward-x toward-y
1696 transform-glyphs)
1697 (and (if-supplied (string)
1698 (string= (slot-value record 'string) string))
1699 (if-supplied (start)
1700 (eql (slot-value record 'start) start))
1701 (if-supplied (end)
1702 (eql (slot-value record 'end) end))
1703 (if-supplied (point-x coordinate)
1704 (coordinate= (slot-value record 'point-x) point-x))
1705 (if-supplied (point-y coordinate)
1706 (coordinate= (slot-value record 'point-y) point-y))
1707 (if-supplied (align-x)
1708 (eq (slot-value record 'align-x) align-x))
1709 (if-supplied (align-y)
1710 (eq (slot-value record 'align-y) align-y))
1711 (if-supplied (toward-x coordinate)
1712 (coordinate= (slot-value record 'toward-x) toward-x))
1713 (if-supplied (toward-y coordinate)
1714 (coordinate= (slot-value record 'toward-y) toward-y))
1715 (if-supplied (transform-glyphs)
1716 (eq (slot-value record 'transform-glyphs) transform-glyphs))))
1717
1718 ;;; 16.3.3. Text Displayed Output Record
1719
1720 (defclass styled-string (gs-text-style-mixin gs-clip-mixin gs-ink-mixin)
1721 ((start-x :initarg :start-x)
1722 (string :initarg :string :reader styled-string-string)))
1723
1724 (defmethod output-record-equal and ((record styled-string)
1725 (record2 styled-string))
1726 (and (coordinate= (slot-value record 'start-x)
1727 (slot-value record2 'start-x))
1728 (string= (slot-value record 'string)
1729 (slot-value record2 'string))))
1730
1731 (defclass standard-text-displayed-output-record
1732 (text-displayed-output-record standard-displayed-output-record)
1733 ((initial-x1 :initarg :start-x)
1734 (initial-y1 :initarg :start-y)
1735 (strings :initform nil)
1736 (baseline :initform 0)
1737 (width :initform 0)
1738 (max-height :initform 0)
1739 (start-x :initarg :start-x)
1740 (start-y :initarg :start-y)
1741 (end-x :initarg :start-x)
1742 (end-y :initarg :start-y)
1743 (wrapped :initform nil
1744 :accessor text-record-wrapped)
1745 (medium :initarg :medium :initform nil)))
1746
1747 (defmethod initialize-instance :after
1748 ((obj standard-text-displayed-output-record) &key stream)
1749 (when stream
1750 (setf (slot-value obj 'medium) (sheet-medium stream))))
1751
1752 ;;; Forget match-output-records-1 for standard-text-displayed-output-record; it
1753 ;;; doesn't make much sense because these records have state that is not
1754 ;;; initialized via initargs.
1755
1756 (defmethod output-record-equal and
1757 ((record standard-text-displayed-output-record)
1758 (record2 standard-text-displayed-output-record))
1759 (with-slots
1760 (initial-x1 initial-y1 start-x start-y end-x end-y wrapped strings)
1761 record2
1762 (and (coordinate= (slot-value record 'initial-x1) initial-x1)
1763 (coordinate= (slot-value record 'initial-y1) initial-y1)
1764 (coordinate= (slot-value record 'start-x) start-x)
1765 (coordinate= (slot-value record 'start-y) start-y)
1766 (coordinate= (slot-value record 'end-x) end-x)
1767 (coordinate= (slot-value record 'end-y) end-y)
1768 (eq (slot-value record 'wrapped) wrapped)
1769 (coordinate= (slot-value record 'baseline)
1770 (slot-value record2 'baseline))
1771 (eql (length (slot-value record 'strings)) (length strings));XXX
1772 (loop for s1 in (slot-value record 'strings)
1773 for s2 in strings
1774 always (output-record-equal s1 s2)))))
1775
1776 (defmethod print-object ((self standard-text-displayed-output-record) stream)
1777 (print-unreadable-object (self stream :type t :identity t)
1778 (with-slots (start-x start-y strings) self
1779 (format stream "~D,~D ~S"
1780 start-x start-y
1781 (mapcar #'styled-string-string strings)))))
1782
1783 (defmethod* (setf output-record-position) :around
1784 (nx ny (record standard-text-displayed-output-record))
1785 (with-standard-rectangle* (:x1 x1 :y1 y1)
1786 record
1787 (with-slots (start-x start-y end-x end-y strings baseline)
1788 record
1789 (let ((dx (- nx x1))
1790 (dy (- ny y1)))
1791 (multiple-value-prog1
1792 (call-next-method)
1793 (incf start-x dx)
1794 (incf start-y dy)
1795 (incf end-x dx)
1796 (incf end-y dy)
1797 ;(incf baseline dy)
1798 (loop for s in strings
1799 do (incf (slot-value s 'start-x) dx)))))))
1800
1801 (defmethod replay-output-record ((record standard-text-displayed-output-record)
1802 stream
1803 &optional region (x-offset 0) (y-offset 0))
1804 (declare (ignore region x-offset y-offset))
1805 (with-slots (strings baseline max-height start-y wrapped)
1806 record
1807 (with-sheet-medium (medium stream) ;is sheet a sheet-with-medium-mixin? --GB
1808 ;; FIXME:
1809 ;; 1. SLOT-VALUE...
1810 ;; 2. It should also save a "current line".
1811 (setf (slot-value stream 'baseline) baseline)
1812 (loop for substring in strings
1813 do (with-slots (start-x string)
1814 substring
1815 (setf (stream-cursor-position stream)
1816 (values start-x start-y))
1817 (set-medium-graphics-state substring medium)
1818 (stream-write-output stream string nil)))
1819 (when wrapped ; FIXME
1820 (draw-rectangle* medium
1821 (+ wrapped 0) start-y
1822 (+ wrapped 4) (+ start-y max-height)
1823 :ink +foreground-ink+
1824 :filled t)))))
1825
1826 (defmethod output-record-start-cursor-position
1827 ((record standard-text-displayed-output-record))
1828 (with-slots (start-x start-y) record
1829 (values start-x start-y)))
1830
1831 (defmethod output-record-end-cursor-position
1832 ((record standard-text-displayed-output-record))
1833 (with-slots (end-x end-y) record
1834 (values end-x end-y)))
1835
1836 (defmethod tree-recompute-extent
1837 ((text-record standard-text-displayed-output-record))
1838 (with-standard-rectangle* (:x1 x1 :y1 y1)
1839 text-record
1840 (with-slots (width max-height)
1841 text-record
1842 (setf (rectangle-edges* text-record)
1843 (values x1 y1
1844 (coordinate (+ x1 width))
1845 (coordinate (+ y1 max-height))))))
1846 text-record)
1847
1848 (defmethod add-character-output-to-text-record ; XXX OAOO with ADD-STRING-...
1849 ((text-record standard-text-displayed-output-record)
1850 character text-style char-width height new-baseline)
1851 (with-slots (strings baseline width max-height start-y end-x end-y medium)
1852 text-record
1853 (if (and strings
1854 (let ((string (last1 strings)))
1855 (match-output-records string
1856 :text-style text-style
1857 :ink (medium-ink medium)
1858 :clipping-region (medium-clipping-region
1859 medium))))
1860 (vector-push-extend character (slot-value (last1 strings) 'string))
1861 (nconcf strings
1862 (list (make-instance
1863 'styled-string
1864 :start-x end-x
1865 :text-style text-style
1866 :medium medium ; pick up ink and clipping region
1867 :string (make-array 1 :initial-element character
1868 :element-type 'character
1869 :adjustable t
1870 :fill-pointer t)))))
1871 (setq baseline (max baseline new-baseline)
1872 end-x (+ end-x char-width)
1873 max-height (max max-height height)
1874 end-y (max end-y (+ start-y max-height))
1875 width (+ width char-width)))
1876 (tree-recompute-extent text-record))
1877
1878 (defmethod add-string-output-to-text-record
1879 ((text-record standard-text-displayed-output-record)
1880 string start end text-style string-width height new-baseline)
1881 (setf end (or end (length string)))
1882 (let ((length (max 0 (- end start))))
1883 (cond
1884 ((eql length 1)
1885 (add-character-output-to-text-record text-record
1886 (aref string start)
1887 text-style
1888 string-width height new-baseline))
1889 (t (with-slots (strings baseline width max-height start-y end-x end-y
1890 medium)
1891 text-record
1892 (let ((styled-string (make-instance
1893 'styled-string
1894 :start-x end-x
1895 :text-style text-style
1896 :medium medium
1897 :string (make-array length
1898 :element-type 'character
1899 :adjustable t
1900 :fill-pointer t))))
1901 (nconcf strings (list styled-string))
1902 (replace (styled-string-string styled-string) string
1903 :start2 start :end2 end))
1904 (setq baseline (max baseline new-baseline)
1905 end-x (+ end-x string-width)
1906 max-height (max max-height height)
1907 end-y (max end-y (+ start-y max-height))
1908 width (+ width string-width)))
1909 (tree-recompute-extent text-record)))))
1910
1911 (defmethod text-displayed-output-record-string
1912 ((record standard-text-displayed-output-record))
1913 (with-slots (strings) record
1914 (if (= 1 (length strings))
1915 (styled-string-string (first strings))
1916 (with-output-to-string (result)
1917 (loop for styled-string in strings
1918 do (write-string (styled-string-string styled-string) result))))))
1919
1920 ;;; 16.3.4. Top-Level Output Records
1921 (defclass stream-output-history-mixin ()
1922 ((stream :initarg :stream :reader output-history-stream)))
1923
1924 (defclass standard-sequence-output-history
1925 (standard-sequence-output-record stream-output-history-mixin)
1926 ())
1927
1928 (defclass standard-tree-output-history
1929 (standard-tree-output-record stream-output-history-mixin)
1930 ())
1931
1932 ;;; 16.4. Output Recording Streams
1933 (defclass standard-output-recording-stream (output-recording-stream)
1934 ((recording-p :initform t :reader stream-recording-p)
1935 (drawing-p :initform t :accessor stream-drawing-p)
1936 (output-history :initform (make-instance 'standard-tree-output-history)
1937 :reader stream-output-history)
1938 (current-output-record :accessor stream-current-output-record)
1939 (current-text-output-record :initform nil
1940 :accessor stream-current-text-output-record)
1941 (local-record-p :initform t
1942 :documentation "This flag is used for dealing with streams outputting strings char-by-char.")))
1943
1944 (defmethod initialize-instance :after
1945 ((stream standard-output-recording-stream) &rest args)
1946 (declare (ignore args))
1947 (let ((history (make-instance 'standard-tree-output-history :stream stream)))
1948 (setf (slot-value stream 'output-history) history
1949 (stream-current-output-record stream) history)))
1950
1951 ;;; Used in initializing clim-stream-pane
1952
1953 (defmethod reset-output-history ((stream
1954 standard-output-recording-stream))
1955 (setf (slot-value stream 'output-history)
1956 (make-instance 'standard-tree-output-history :stream stream))
1957 (setf (stream-current-output-record stream) (stream-output-history stream)))
1958
1959 ;;; 16.4.1 The Output Recording Stream Protocol
1960 (defmethod (setf stream-recording-p)
1961 (recording-p (stream standard-output-recording-stream))
1962 (let ((old-val (slot-value stream 'recording-p)))
1963 (setf (slot-value stream 'recording-p) recording-p)
1964 (when (not (eq old-val recording-p))
1965 (stream-close-text-output-record stream))
1966 recording-p))
1967
1968 (defmethod stream-add-output-record
1969 ((stream standard-output-recording-stream) record)
1970 (add-output-record record (stream-current-output-record stream)))
1971
1972 (defmethod stream-replay
1973 ((stream standard-output-recording-stream) &optional region)
1974 (replay (stream-output-history stream) stream region))
1975
1976 (defun output-record-ancestor-p (ancestor child)
1977 (loop for record = child then parent
1978 for parent = (output-record-parent record)
1979 when (eq parent nil) do (return nil)
1980 when (eq parent ancestor) do (return t)))
1981
1982 (defmethod erase-output-record (record (stream standard-output-recording-stream)
1983 &optional (errorp t))
1984 (letf (((stream-recording-p stream) nil))
1985 (let ((region (bounding-rectangle record)))
1986 (with-bounding-rectangle* (x1 y1 x2 y2) region
1987 (if (output-record-ancestor-p (stream-output-history stream) record)
1988 (progn
1989 (delete-output-record record (output-record-parent record))
1990 (with-output-recording-options (stream :record nil)
1991 (draw-rectangle* stream x1 y1 x2 y2 :ink +background-ink+))
1992 (stream-replay stream region))
1993 (when errorp
1994 (error "~S is not contained in ~S." record stream)))))))
1995
1996 ;;; 16.4.3. Text Output Recording
1997 (defmethod stream-text-output-record
1998 ((stream standard-output-recording-stream) text-style)
1999 (declare (ignore text-style))
2000 (let ((record (stream-current-text-output-record stream)))
2001 (unless (and record (typep record 'standard-text-displayed-output-record))
2002 (multiple-value-bind (cx cy) (stream-cursor-position stream)
2003 (setf record (make-instance 'standard-text-displayed-output-record
2004 :x-position cx :y-position cy
2005 :start-x cx :start-y cy
2006 :stream stream)
2007 (stream-current-text-output-record stream) record)))
2008 record))
2009
2010 (defmethod stream-close-text-output-record
2011 ((stream standard-output-recording-stream))
2012 (let ((record (stream-current-text-output-record stream)))
2013 (when record
2014 (setf (stream-current-text-output-record stream) nil)
2015 #|record stream-current-cursor-position to (end-x record) - already done|#
2016 (stream-add-output-record stream record))))
2017
2018 (defmethod stream-add-character-output
2019 ((stream standard-output-recording-stream)
2020 character text-style width height baseline)
2021 (add-character-output-to-text-record
2022 (stream-text-output-record stream text-style)
2023 character text-style width height baseline))
2024
2025 (defmethod stream-add-string-output ((stream standard-output-recording-stream)
2026 string start end text-style
2027 width height baseline)
2028 (add-string-output-to-text-record (stream-text-output-record stream
2029 text-style)
2030 string start end text-style
2031 width height baseline))
2032
2033 ;;; Text output catching methods
2034 (defmacro without-local-recording (stream &body body)
2035 `(letf (((slot-value ,stream 'local-record-p) nil))
2036 ,@body))
2037
2038 (defmethod stream-write-output :around
2039 ((stream standard-output-recording-stream)
2040 line
2041 string-width
2042 &optional (start 0) end)
2043 (when (and (stream-recording-p stream)
2044 (slot-value stream 'local-record-p))
2045 (let* ((medium (sheet-medium stream))
2046 (text-style (medium-text-style medium))
2047 (height (text-style-height text-style medium))
2048 (ascent (text-style-ascent text-style medium)))
2049 (if (characterp line)
2050 (stream-add-character-output stream line text-style
2051 (stream-character-width
2052 stream line :text-style text-style)
2053 height
2054 ascent)
2055 (stream-add-string-output stream line start end text-style
2056 (or string-width
2057 (stream-string-width stream line
2058 :start start :end end
2059 :text-style text-style))
2060 height
2061 ascent))))
2062 (when (stream-drawing-p stream)
2063 (without-local-recording stream
2064 (call-next-method))))
2065
2066 #+nil
2067 (defmethod stream-write-char :around ((stream standard-output-recording-stream) char)
2068 (when (and (stream-recording-p stream)
2069 (slot-value stream 'local-record-p))
2070 (if (or (eql char #\return)
2071
2072 (stream-close-text-output-record stream)
2073 (let* ((medium (sheet-medium stream))
2074 (text-style (medium-text-style medium)))
2075 (stream-add-character-output stream char text-style
2076 (stream-character-width stream char :text-style text-style)
2077 (text-style-height text-style medium)
2078 (text-style-ascent text-style medium)))))
2079 (without-local-recording stream
2080 (call-next-method))))
2081
2082 #+nil
2083 (defmethod stream-write-string :around ((stream standard-output-recording-stream) string
2084 &optional (start 0) end)
2085 (when (and (stream-recording-p stream)
2086 (slot-value stream 'local-record-p))
2087 (let* ((medium (sheet-medium stream))
2088 (text-style (medium-text-style medium)))
2089 (stream-add-string-output stream string start end text-style
2090 (stream-string-width stream string
2091 :start start :end end
2092 :text-style text-style)
2093 (text-style-height text-style medium)
2094 (text-style-ascent text-style medium))))
2095 (without-local-recording stream
2096 (call-next-method)))
2097
2098
2099 (defmethod stream-finish-output :after ((stream standard-output-recording-stream))
2100 (stream-close-text-output-record stream))
2101
2102 (defmethod stream-force-output :after ((stream standard-output-recording-stream))
2103 (stream-close-text-output-record stream))
2104
2105 (defmethod stream-terpri :after ((stream standard-output-recording-stream))
2106 (stream-close-text-output-record stream))
2107
2108 (defmethod* (setf stream-cursor-position) :after (x y (stream standard-output-recording-stream))
2109 (declare (ignore x y))
2110 (stream-close-text-output-record stream))
2111
2112 ;(defmethod stream-set-cursor-position :after ((stream standard-output-recording-stream))
2113 ; (stream-close-text-output-record stream))
2114
2115 (defmethod stream-wrap-line :before ((stream standard-output-recording-stream))
2116 (when (stream-recording-p stream)
2117 (setf (text-record-wrapped (stream-text-output-record stream nil)) ; FIXME!
2118 (stream-text-margin stream))))
2119
2120 ;;; 16.4.4. Output Recording Utilities
2121
2122 (defmethod invoke-with-output-recording-options
2123 ((stream output-recording-stream) continuation record draw)
2124 "Calls CONTINUATION on STREAM enabling or disabling recording and drawing
2125 according to the flags RECORD and DRAW."
2126 (letf (((stream-recording-p stream) record)
2127 ((stream-drawing-p stream) draw))
2128 (funcall continuation stream)))
2129
2130 (defmethod invoke-with-new-output-record ((stream output-recording-stream)
2131 continuation record-type
2132 constructor
2133 &key parent)
2134 (declare (ignore record-type))
2135 (stream-close-text-output-record stream)
2136 (let ((new-record (funcall constructor)))
2137 (letf (((stream-current-output-record stream) new-record))
2138 ;; Should we switch on recording? -- APD
2139 (funcall continuation stream new-record)
2140 (finish-output stream))
2141 (if parent
2142 (add-output-record new-record parent)
2143 (stream-add-output-record stream new-record))
2144 new-record))
2145
2146 (defmethod invoke-with-new-output-record ((stream output-recording-stream)
2147 continuation record-type
2148 (constructor null)
2149 &rest initargs
2150 &key parent)
2151 (with-keywords-removed (initargs (:parent))
2152 (stream-close-text-output-record stream)
2153 (let ((new-record (apply #'make-instance record-type initargs)))
2154 (letf (((stream-current-output-record stream) new-record))
2155 ;; Should we switch on recording? -- APD
2156 (funcall continuation stream new-record)
2157 (finish-output stream))
2158 (if parent
2159 (add-output-record new-record parent)
2160 (stream-add-output-record stream new-record))
2161 new-record)))
2162
2163 (defmethod invoke-with-output-to-output-record
2164 ((stream output-recording-stream) continuation record-type constructor
2165 &key)
2166 (declare (ignore record-type))
2167 (stream-close-text-output-record stream)
2168 (let ((new-record (funcall constructor)))
2169 (with-output-recording-options (stream :record t :draw nil)
2170 (letf (((stream-current-output-record stream) new-record)
2171 ((stream-cursor-position stream) (values 0 0)))
2172 (funcall continuation stream new-record)
2173 (finish-output stream)))
2174 new-record))
2175
2176 (defmethod invoke-with-output-to-output-record
2177 ((stream output-recording-stream) continuation record-type (constructor null)
2178 &rest initargs)
2179 (stream-close-text-output-record stream)
2180 (let ((new-record (apply #'make-instance record-type initargs)))
2181 (with-output-recording-options (stream :record t :draw nil)
2182 (letf (((stream-current-output-record stream) new-record)
2183 ((stream-cursor-position stream) (values 0 0)))
2184 (funcall continuation stream new-record)
2185 (finish-output stream)))
2186 new-record))
2187
2188 (defmethod make-design-from-output-record (record)
2189 ;; FIXME
2190 (declare (ignore record))
2191 (error "Not implemented."))
2192
2193
2194 ;;; Additional methods
2195 (defmethod scroll-vertical :around ((stream output-recording-stream) dy)
2196 (declare (ignore dy))
2197 (with-output-recording-options (stream :record nil)
2198 (call-next-method)))
2199
2200 (defmethod scroll-horizontal :around ((stream output-recording-stream) dx)
2201 (declare (ignore dx))
2202 (with-output-recording-options (stream :record nil)
2203 (call-next-method)))
2204
2205 ;;; Helper function to break some infinite recursion issues with
2206 ;;; handle-repaint vs. redisplay-frame-pane (in the Listener, that
2207 ;;; is; is this the right place for the fix? )
2208
2209 ;;; FIXME: Change things so the rectangle below is only drawn in response
2210 ;;; to explicit repaint requests from the user, not exposes from X
2211 ;;; FIXME: Use DRAW-DESIGN*, that is fix DRAW-DESIGN*.
2212
2213 (defun %handle-repaint (stream region)
2214 (when (output-recording-stream-p stream)
2215 (let ((region (bounding-rectangle region)))
2216 (with-bounding-rectangle* (x1 y1 x2 y2) region
2217 (with-output-recording-options (stream :record nil)
2218 (draw-rectangle* stream x1 y1 x2 y2 :filled T :ink +background-ink+)))
2219 (stream-replay stream region))))
2220
2221 (defmethod handle-repaint ((stream output-recording-stream) region)
2222 (%handle-repaint stream region))
2223
2224 (defmethod scroll-extent :around ((stream output-recording-stream) x y)
2225 (declare (ignore x y))
2226 (when (stream-drawing-p stream)
2227 (call-next-method)))
2228
2229 ;;; ----------------------------------------------------------------------------
2230 ;;; Complicated, underspecified...
2231 ;;;
2232 ;;; From examining old Genera documentation, I believe that
2233 ;;; with-room-for-graphics is supposed to set the medium transformation to
2234 ;;; give the desired coordinate system; i.e., it doesn't preserve any
2235 ;;; rotation, scaling or translation in the current medium transformation.
2236 (defmethod invoke-with-room-for-graphics (cont stream
2237 &key (first-quadrant t)
2238 height
2239 (move-cursor t)
2240 (record-type
2241 'standard-sequence-output-record))
2242 ;; I am not sure what exactly :height should do.
2243 ;; --GB 2003-05-25
2244 ;; The current behavior is consistent with 'classic' CLIM
2245 ;; --Hefner 2004-06-19
2246 ;; Don't know if it still is :)
2247 ;; -- Moore 2005-01-26
2248 (multiple-value-bind (cx cy)
2249 (stream-cursor-position stream)
2250 (with-sheet-medium (medium stream)
2251 (letf (((medium-transformation medium)
2252 (if first-quadrant
2253 (make-scaling-transformation 1 -1)
2254 +identity-transformation+)))
2255 (let ((record (with-output-to-output-record (stream record-type)
2256 (funcall cont stream))))
2257 ;; Bounding rectangle is in sheet coordinates!
2258 (with-bounding-rectangle* (x1 y1 x2 y2)
2259 record
2260 (declare (ignore x2))
2261 (if first-quadrant
2262 (setf (output-record-position record)
2263 (values (max cx (+ cx x1))
2264 (if height
2265 (max cy (+ cy (- height (- y2 y1))))
2266 cy)))
2267 (setf (output-record-position record)
2268 (values (max cx (+ cx x1)) (max cy (+ cy y1)))))
2269 (when (stream-recording-p stream)
2270 (stream-add-output-record stream record))
2271 (when (stream-drawing-p stream)
2272 (replay record stream))
2273 (if move-cursor
2274 (let ((record-height (- y2 y1)))
2275 (setf (stream-cursor-position stream)
2276 (values cx
2277 (if first-quadrant
2278 (+ cy (max (- y1)
2279 (or height 0)
2280 record-height))
2281 (+ cy (max (or height 0)
2282 record-height))))))
2283 (setf (stream-cursor-position stream) (values cx cy)))
2284 record))))))
2285
2286
2287
2288 (defmethod repaint-sheet ((sheet output-recording-stream) region)
2289 (map-over-sheets-overlapping-region #'(lambda (s)
2290 (%handle-repaint s region))
2291 sheet
2292 region))
2293
2294 ;;; ----------------------------------------------------------------------------
2295 ;;; Baseline
2296 ;;;
2297
2298 (defmethod output-record-baseline ((record output-record))
2299 "Fall back method"
2300 (with-bounding-rectangle* (x1 y1 x2 y2)
2301 record
2302 (declare (ignore x1 x2))
2303 (values (- y2 y1) nil)))
2304
2305 (defmethod output-record-baseline ((record standard-text-displayed-output-record))
2306 (with-slots (baseline) record
2307 (values
2308 baseline
2309 t)))
2310
2311 (defmethod output-record-baseline ((record compound-output-record))
2312 (map-over-output-records (lambda (sub-record)
2313 (multiple-value-bind (baseline definitive)
2314 (output-record-baseline sub-record)
2315 (when definitive
2316 (return-from output-record-baseline
2317 (values baseline t)))))
2318 record)
2319 (call-next-method))
2320
2321 ;;; ----------------------------------------------------------------------------
2322 ;;; copy-textual-output
2323 ;;;
2324
2325 (defun copy-textual-output-history (window stream &optional region record)
2326 (unless region (setf region +everywhere+))
2327 (unless record (setf record (stream-output-history window)))
2328 (let* ((text-style (medium-default-text-style window))
2329 (char-width (stream-character-width window #\n :text-style text-style))
2330 (line-height (+ (stream-line-height window :text-style text-style)
2331 (stream-vertical-spacing window))))
2332 #+NIL
2333 (print (list char-width line-height
2334 (stream-line-height window :text-style text-style)
2335 (stream-vertical-spacing window))
2336 *trace-output*)
2337 ;; humble first ...
2338 (let ((cy nil)
2339 (cx 0))
2340 (labels ((grok-record (record)
2341 (cond ((typep record 'standard-text-displayed-output-record)
2342 (with-slots (start-y start-x end-x strings) record
2343 (setf cy (or cy start-y))
2344 #+NIL
2345 (print (list (list cx cy)
2346 (list start-x end-x start-y))
2347 *trace-output*)
2348 (when (> start-y cy)
2349 (dotimes (k (round (- start-y cy) line-height))
2350 (terpri stream))
2351 (setf cy start-y
2352 cx 0))
2353 (dotimes (k (round (- start-x cx) char-width))
2354 (princ " " stream))
2355 (setf cx end-x)
2356 (dolist (string strings)
2357 (with-slots (string) string
2358 (princ string stream))
2359 #+NIL
2360 (print (list start-x start-y string)
2361 *trace-output*))))
2362 (t
2363 (map-over-output-records-overlapping-region #'grok-record
2364 record region)))))
2365 (grok-record record)))))
2366
2367 ;;; Debugging hacks
2368
2369 (defmethod count-records (r)
2370 (declare (ignore r))
2371 1)
2372
2373 (defmethod count-records ((r compound-output-record))
2374 (let ((count 0))
2375 (map-over-output-records
2376 (lambda (child)
2377 (incf count (count-records child)))
2378 r)
2379 (1+ count)))
2380
2381 (defmethod count-displayed-records ((r displayed-output-record))
2382 1)
2383
2384 (defmethod count-displayed-records ((r compound-output-record))
2385 (let ((count 0))
2386 (map-over-output-records
2387 (lambda (child)
2388 (incf count (count-records child)))
2389 r)
2390 count))

  ViewVC Help
Powered by ViewVC 1.1.5