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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.98 - (show annotations)
Sun Nov 30 00:05:28 2003 UTC (10 years, 4 months ago) by hefner1
Branch: MAIN
Changes since 1.97: +5 -5 lines
Fixes to make incremental redisplay and WITH-OUTPUT-AS-GADGET play nice
together.

* Replace instaces of (setf (output-record-parent foo) nil) with calls to
  DELETE-OUTPUT-RECORD so as to not undermine the got/lost sheet
  notifications. We could use something like REPARENT-OUTPUT-RECORD here,
  but I'm not going to implement it until there is some real use of gadget
  output records to demonstrate its necessity.

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

  ViewVC Help
Powered by ViewVC 1.1.5