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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.43 - (show annotations)
Mon Jun 3 02:15:59 2002 UTC (11 years, 10 months ago) by adejneka
Branch: MAIN
Changes since 1.42: +53 -1 lines
* [INVOKE-]WITH-OUTPUT-TO-OUTPUT-RECORD: implemented.
1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 1998,1999,2000,2001 by Michael McDonald (mikemac@mikemac.com)
4 ;;; (c) copyright 2000 by
5 ;;; Robert Strandh (strandh@labri.u-bordeaux.fr)
6 ;;; (c) copyright 2001 by
7 ;;; Arnaud Rouanet (rouanet@emi.u-bordeaux.fr)
8 ;;; Lionel Salabartan (salabart@emi.u-bordeaux.fr)
9 ;;; (c) copyright 2001, 2002 by Alexey Dejneka (adejneka@comail.ru)
10
11 ;;; This library is free software; you can redistribute it and/or
12 ;;; modify it under the terms of the GNU Library General Public
13 ;;; License as published by the Free Software Foundation; either
14 ;;; version 2 of the License, or (at your option) any later version.
15 ;;;
16 ;;; This library is distributed in the hope that it will be useful,
17 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
19 ;;; Library General Public License for more details.
20 ;;;
21 ;;; You should have received a copy of the GNU Library General Public
22 ;;; License along with this library; if not, write to the
23 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 ;;; Boston, MA 02111-1307 USA.
25
26 ;;; TODO:
27 ;;; - Scrolling does not work correctly. Region is given in "window" coordinates,
28 ;;; without bounding-rectangle-position transformation.
29 ;;; - Redo setf*-output-record-position, extent recomputation for
30 ;;; compound records
31 ;;; - How to deal with mixing of positioning/modifying?
32 ;;; - When DRAWING-P is NIL, should stream cursor move?
33 ;;; - OUTPUT-RECORD is a protocol class, it should not have any slots/methods.
34
35 (in-package :CLIM-INTERNALS)
36
37 ;;; Should we blow off standard-bounding-rectangle and implement the
38 ;;; bounding rectangle protocol ourselves? Or use x1,y1 from
39 ;;; standard-bounding-rectangle as our position?
40
41 (defclass basic-output-record (bounding-rectangle)
42 ()
43 (:documentation "Internal protocol class for common elements of output-record
44 and displayed-output-record"))
45
46 (defclass basic-output-record-mixin (standard-bounding-rectangle
47 basic-output-record)
48 ((x :initarg :x-position
49 :initform 0
50 :type rational)
51 (y :initarg :y-position
52 :initform 0
53 :type rational)
54 (parent :initarg :parent
55 :initform nil
56 :reader output-record-parent))
57 (:documentation "Implementation class for the Basic Output Record Protocol"))
58
59 (defmethod initialize-instance :after ((record basic-output-record-mixin)
60 &rest args)
61 (declare (ignore args))
62 (with-slots (x y x1 y1 x2 y2) record
63 (setq x1 x
64 y1 y
65 x2 x
66 y2 y)))
67
68 (defclass output-record (basic-output-record)
69 ())
70
71 (defun output-record-p (x)
72 (typep x 'output-record))
73
74 (defclass output-record-mixin (basic-output-record-mixin output-record)
75 ()
76 (:documentation "Implementation class for output records i.e., those records
77 that have children."))
78
79 (defclass displayed-output-record (basic-output-record)
80 ())
81
82 (defclass displayed-output-record-mixin (basic-output-record-mixin
83 displayed-output-record)
84 ((ink :initarg :ink :reader displayed-output-record-ink)
85 (initial-x1 :initarg :initial-x1)
86 (initial-y1 :initarg :initial-y1))
87 (:documentation "Implementation class for displayed-output-record."))
88
89 (defun displayed-output-record-p (x)
90 (typep x 'displayed-output-record))
91
92 ; 16.2.1. The Basic Output Record Protocol
93 #+:cmu(declaim (ftype (function (output-record) (values rational rational))
94 output-record-position))
95 (defgeneric output-record-position (record)
96 (:documentation
97 "Returns the x and y position of RECORD. The position is the
98 position of the upper-left corner of its bounding rectangle. The
99 position is relative to the stream, where (0,0) is (initially) the
100 upper-left corner of the stream."))
101
102 (defgeneric* (setf output-record-position) (x y record))
103
104 #+:cmu(declaim (ftype (function (output-record) (values integer integer))
105 output-record-start-cursor-position))
106 (defgeneric output-record-start-cursor-position (record)
107 (:documentation
108 "Returns the x and y starting cursor position of RECORD. The
109 positions are relative to the stream, where (0,0) is (initially) the
110 upper-left corner of the stream."))
111
112 (defgeneric* (setf output-record-start-cursor-position) (x y record))
113
114 #+:cmu(declaim (ftype (function (output-record) (values integer integer))
115 output-record-end-cursor-position))
116 (defgeneric output-record-end-cursor-position (record)
117 (:documentation
118 "Returns the x and y ending cursor position of RECORD. The
119 positions are relative to the stream, where (0,0) is (initially) the
120 upper-left corner of the stream."))
121
122 (defgeneric* (setf output-record-end-cursor-position) (x y record))
123
124 (defgeneric output-record-parent (record)
125 (:documentation
126 "Returns the output record that is the parent of RECORD, or nil if
127 RECORD has no parent."))
128
129 (defgeneric replay-output-record (record stream
130 &optional region x-offset y-offset)
131 (:documentation "Displays the output captured by RECORD on the
132 STREAM, exactly as it was originally captured. The current user
133 transformation, line style, text style, ink and clipping region of
134 STREAM are all ignored. Instead, these are gotten from the output
135 record.
136
137 Only those records that overlap REGION are displayed."))
138
139 (defgeneric output-record-hit-detection-rectangle* (record))
140
141 (defgeneric output-record-refined-position-test (record x y))
142
143 (defgeneric highlight-output-record (record stream state))
144
145 (defgeneric displayed-output-record-ink (displayed-output-record))
146
147 ; 16.2.2. Output Record "Database" Protocol
148
149 (defgeneric output-record-children (record))
150
151 (defgeneric add-output-record (child record))
152
153 (defgeneric delete-output-record (child record &optional (errorp t)))
154
155 (defgeneric clear-output-record (record))
156
157 (defgeneric output-record-count (record))
158
159 (defgeneric map-over-output-records-containing-position
160 (function record x y &optional x-offset y-offset &rest function-args))
161
162 (defgeneric map-over-output-records-overlapping-region
163 (function record region &optional x-offset y-offset &rest function-args))
164
165 ;;; From the Franz CLIM user's guide but not in the spec... clearly necessary.
166 (defgeneric map-over-output-records
167 (continuation record &optional x-offset y-offset &rest continuation-args))
168
169 ; 16.2.3. Output Record Change Notification Protocol
170
171 (defgeneric recompute-extent-for-new-child (record child))
172
173 (defgeneric recompute-extent-for-changed-child
174 (record child old-min-x old-min-y old-max-x old-max-y))
175
176 (defgeneric tree-recompute-extent (record))
177
178 ;;; Methods
179
180 (defmethod output-record-position ((record basic-output-record-mixin))
181 (with-slots (x y) record
182 (values x y)))
183
184 (defvar *suppress-notify-parent* nil
185 "When t, don't notify the parent of a change in an output record's
186 bounding rectangle.")
187
188 (defmethod* (setf output-record-position)
189 (nx ny (record basic-output-record-mixin))
190 (with-slots (x y x1 y1 x2 y2) record
191 (let ((dx (- nx x))
192 (dy (- ny y)))
193 (incf x1 dx) (incf y1 dy)
194 (incf x2 dx) (incf y2 dy))
195 (setq x nx
196 y ny)))
197
198 (defmethod* (setf output-record-position) :before
199 (nx ny (record output-record))
200 (let ((*suppress-notify-parent* t))
201 (multiple-value-bind (old-x old-y) (output-record-position record)
202 (let ((dx (- nx old-x))
203 (dy (- ny old-y)))
204 (map-over-output-records
205 #'(lambda (child)
206 (multiple-value-bind (x y) (output-record-position child)
207 (setf (output-record-position child)
208 (values (+ x dx) (+ y dy)))))
209 record)))))
210
211 (defmethod* (setf output-record-position) :around
212 (nx ny (record basic-output-record))
213 (declare (ignore nx ny))
214 (if *suppress-notify-parent*
215 (call-next-method)
216 (with-bounding-rectangle* (min-x min-y max-x max-y) record
217 (call-next-method)
218 (let ((parent (output-record-parent record)))
219 (when parent
220 (recompute-extent-for-changed-child parent record
221 min-x min-y max-x max-y))))))
222
223
224 (defmethod output-record-start-cursor-position ((record basic-output-record))
225 (values nil nil))
226
227 (defmethod* (setf output-record-start-cursor-position)
228 (x y (record basic-output-record))
229 (declare (ignore x y))
230 nil)
231
232 (defmethod output-record-end-cursor-position ((record basic-output-record))
233 (values nil nil))
234
235 (defmethod* (setf output-record-end-cursor-position)
236 (x y (record basic-output-record))
237 (declare (ignore x y))
238 nil)
239
240 (defun replay (record stream &optional region)
241 (stream-close-text-output-record stream)
242 (when (stream-drawing-p stream)
243 (with-cursor-off stream
244 (multiple-value-bind (cx cy) (stream-cursor-position stream)
245 (unwind-protect
246 (letf (((stream-recording-p stream) nil))
247 (replay-output-record record stream region))
248 (setf (stream-cursor-position stream) (values cx cy)))))))
249
250 (defmethod replay-output-record ((record output-record) stream
251 &optional region (x-offset 0) (y-offset 0))
252 (when (null region)
253 (setq region +everywhere+))
254 (map-over-output-records-overlapping-region
255 #'replay-output-record record region x-offset y-offset
256 stream region x-offset y-offset))
257
258 ;;; XXX ? should this be defined on output-record at all?
259 ;;; Probably not -- moore
260 (defmethod erase-output-record ((record output-record) stream
261 &optional (errorp t))
262 (declare (ignore stream errorp))
263 nil)
264
265 (defmethod output-record-hit-detection-rectangle*
266 ((record basic-output-record))
267 (bounding-rectangle* record))
268
269 (defmethod output-record-refined-position-test ((record basic-output-record)
270 x y)
271 (declare (ignore x y))
272 t)
273
274 ;;; XXX Should this only be defined on recording streams?
275 (defmethod highlight-output-record ((record basic-output-record-mixin)
276 stream state)
277 (multiple-value-bind (x1 y1 x2 y2)
278 (output-record-hit-detection-rectangle* record)
279 (ecase state
280 (:highlight
281 (draw-rectangle* (sheet-medium stream) x1 y1 x2 y2
282 :filled nil :ink +foreground-ink+))
283 (:unhighlight
284 (draw-rectangle* (sheet-medium stream) x1 y1 x2 y2
285 :filled nil :ink +background-ink+)))))
286
287 (defclass standard-sequence-output-record (output-record-mixin)
288 ((children :initform (make-array 8 :adjustable t :fill-pointer 0)
289 :reader output-record-children)))
290
291 ;;; XXX bogus for now.
292 (defclass standard-tree-output-record (standard-sequence-output-record)
293 (
294 ))
295
296 #+nil
297 (defmethod* (setf output-record-position)
298 (nx ny (record standard-sequence-output-record))
299 (with-slots (x y) record
300 (setq x nx
301 y ny)))
302
303 (defmethod add-output-record (child (record standard-sequence-output-record))
304 (with-slots (children) record
305 (vector-push-extend child children))
306 (with-slots (parent) child
307 (setf parent record)))
308
309 (defmethod add-output-record :before (child (record output-record-mixin))
310 (when (zerop (output-record-count record))
311 (with-slots (x1 y1 x2 y2) record
312 (setf (values x1 y1 x2 y2) (bounding-rectangle* child)))))
313
314 (defmethod add-output-record :after (child (record output-record))
315 (recompute-extent-for-new-child record child))
316
317 (defmethod delete-output-record (child (record standard-sequence-output-record)
318 &optional (errorp t))
319 (with-slots (children) record
320 (let ((pos (position child children :test #'eq)))
321 (if (null pos)
322 (when errorp
323 (error "~S is not a child of ~S" child record))
324 (progn
325 (setq children (replace children children
326 :start1 pos
327 :start2 (1+ pos)))
328 (decf (fill-pointer children)))))))
329
330 (defmethod delete-output-record :after (child (record output-record-mixin)
331 &optional (errorp t))
332 (declare (ignore errorp))
333 (with-bounding-rectangle* (x1 y1 x2 y2) child
334 (recompute-extent-for-changed-child record child x1 y1 x2 y2)))
335
336 (defmethod clear-output-record ((record standard-sequence-output-record))
337 (with-slots (children x1 y1 x2 y2) record
338 (fill children nil)
339 (setf (fill-pointer children) 0)
340 (setq x2 x1
341 y2 y1)))
342
343 (defmethod output-record-count ((record standard-sequence-output-record))
344 (length (output-record-children record)))
345
346 (defmethod map-over-output-records
347 (function (record standard-sequence-output-record)
348 &optional (x-offset 0) (y-offset 0)
349 &rest function-args)
350 (declare (ignore x-offset y-offset))
351 (loop for child across (output-record-children record)
352 do (apply function child function-args)))
353
354 ;;; This needs to work in "most recently added first" order, which I
355 ;;; didn't know until recently :) -- moore
356 (defmethod map-over-output-records-containing-position
357 (function (record standard-sequence-output-record) x y
358 &optional (x-offset 0) (y-offset 0)
359 &rest function-args)
360 (declare (ignore x-offset y-offset))
361 (with-slots (children) record
362 (loop for i from (1- (length children)) downto 0
363 for child = (aref children i)
364 when (and (multiple-value-bind (min-x min-y max-x max-y)
365 (output-record-hit-detection-rectangle* child)
366 (and (<= min-x x max-x) (<= min-y y max-y)))
367 (output-record-refined-position-test child x y))
368 do (apply function child function-args))))
369
370 (defmethod map-over-output-records-overlapping-region
371 (function (record standard-sequence-output-record) region
372 &optional (x-offset 0) (y-offset 0)
373 &rest function-args)
374 (declare (ignore x-offset y-offset))
375 (loop for child across (output-record-children record)
376 do (when (region-intersects-region-p region child)
377 (apply function child function-args))))
378
379 ;;; If the child is the only child of record, the record's bounding rectangle
380 ;;; is set to the child's.
381 (defmethod recompute-extent-for-new-child
382 ((record standard-sequence-output-record) child)
383 (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2) record
384 (with-slots (parent children x1 y1 x2 y2) record
385 (if (eql 1 (length children))
386 (setf (values x1 y1 x2 y2) (bounding-rectangle* child))
387 (with-bounding-rectangle* (x1-child y1-child x2-child y2-child) child
388 (minf x1 x1-child)
389 (minf y1 y1-child)
390 (maxf x2 x2-child)
391 (maxf y2 y2-child)))
392 (when parent
393 (recompute-extent-for-changed-child parent record
394 old-x1 old-y1 old-x2 old-y2)))))
395
396 (defmethod recompute-extent-for-changed-child :around
397 ((record basic-output-record-mixin) child
398 old-min-x old-min-y old-max-x old-max-y)
399 (declare (ignore child old-min-x old-min-y old-max-x old-max-y))
400 (let ((old-rectangle (multiple-value-call #'make-bounding-rectangle
401 (bounding-rectangle* record))))
402 (call-next-method)
403 (with-slots (parent x1 y1 x2 y2) record
404 (when (and parent (not (region-equal old-rectangle record)))
405 (recompute-extent-for-changed-child parent record x1 y1 x2 y2)))))
406
407 ;; Internal helper function
408 (defmethod %tree-recompute-extent* ((record output-record))
409 (let ((new-x1 0)
410 (new-y1 0)
411 (new-x2 0)
412 (new-y2 0)
413 (first-time t))
414 (map-over-output-records
415 #'(lambda (child)
416 (if first-time
417 (progn
418 (setf (values new-x1 new-y1 new-x2 new-y2)
419 (bounding-rectangle* child))
420 (setq first-time nil))
421 (with-bounding-rectangle* (cx1 cy1 cx2 cy2) child
422 (minf new-x1 cx1)
423 (minf new-y1 cy1)
424 (maxf new-x2 cx2)
425 (maxf new-y2 cy2))))
426 record)
427 ;; If we don't have any children, collapse the bbox to the min point.
428 (if first-time
429 (multiple-value-bind (x1 y1)
430 (output-record-position record)
431 (values x1 y1 x1 y1))
432 (values new-x1 new-y1 new-x2 new-y2))))
433
434 (defmethod recompute-extent-for-changed-child
435 ((record output-record-mixin) changed-child
436 old-min-x old-min-y old-max-x old-max-y)
437 ;; If the child's old and new bbox lies entirely within the record's bbox
438 ;; then no change need be made to the record's bbox. Otherwise, if some part
439 ;; of the child's bbox was on the record's bbox and is now inside, examine
440 ;; all the children to determine the correct new bbox.
441 (with-slots (x1 y1 x2 y2) record
442 (with-bounding-rectangle* (child-x1 child-y1 child-x2 child-y2)
443 changed-child
444 (unless (and (> x1 old-min-x)
445 (> y1 old-min-y)
446 (< x2 old-max-x)
447 (< y2 old-max-y)
448 (> x1 child-x1)
449 (> y1 child-y1)
450 (< x2 child-x2)
451 (< y2 child-y2))
452 ;; Don't know if changed-child has been deleted or what, so go through
453 ;; all the children and construct the updated bbox.
454 (setf (values x1 y1 x2 y2) (%tree-recompute-extent* record))
455 nil))))
456
457 (defmethod tree-recompute-extent ((record output-record-mixin))
458 (with-slots (x1 y1 x2 y2) record
459 (setf (values x1 y1 x2 y2) (%tree-recompute-extent* record))
460 nil))
461
462
463 (defmethod tree-recompute-extent :around ((record output-record))
464 (let ((old-rectangle (multiple-value-call #'make-bounding-rectangle
465 (bounding-rectangle* record))))
466 (call-next-method)
467 (with-slots (parent x1 y1 x2 y2) record
468 (when (and parent (not (region-equal old-rectangle record)))
469 (recompute-extent-for-changed-child parent record x1 y1 x2 y2)))))
470
471
472 ;;; Graphics recording classes
473
474 (defclass graphics-displayed-output-record (displayed-output-record)
475 ())
476
477 (defclass graphics-displayed-output-record-mixin
478 (displayed-output-record-mixin graphics-displayed-output-record)
479 ((clip :initarg :clipping-region
480 :documentation "Clipping region in user coordinates.")
481 (transform :initarg :transformation)
482 (line-style :initarg :line-style)
483 (text-style :initarg :text-style)
484 ))
485
486 (defun graphics-displayed-output-record-p (x)
487 (typep x 'graphics-displayed-output-record))
488
489
490 ;;; stream-output-history-mixin class
491
492 (defclass stream-output-history-mixin ()
493 ())
494
495 (defclass standard-sequence-output-history
496 (standard-sequence-output-record stream-output-history-mixin)
497 ())
498
499 (defclass standard-tree-output-history
500 (standard-tree-output-record stream-output-history-mixin)
501 ())
502
503
504 ;;; Output-Recording-Stream class
505
506 (defclass output-recording-stream ()
507 ())
508
509 (defun output-recording-stream-p (x)
510 (typep x 'output-recording-stream))
511
512 (defclass standard-output-recording-stream (output-recording-stream)
513 ((recording-p :initform t :reader stream-recording-p)
514 (drawing-p :initform t :accessor stream-drawing-p)
515 (output-history :initform (make-instance 'standard-tree-output-history)
516 :reader stream-output-history)
517 (current-output-record :accessor stream-current-output-record)
518 (current-text-output-record :initform nil
519 :accessor stream-current-text-output-record)
520 (local-record-p :initform t
521 :documentation "This flag is used for dealing with streams outputting strings char-by-char.")))
522
523 ;;; 16.4.1 The Output Recording Stream Protocol
524 (defgeneric stream-recording-p (stream))
525
526 (defgeneric (setf stream-recording-p) (recording-p stream))
527
528 (defgeneric stream-drawing-p (stream))
529
530 (defgeneric (setf stream-drawing-p) (drawing-p stream))
531
532 (defgeneric stream-output-history (stream))
533
534 (defgeneric stream-current-output-record (stream))
535
536 (defgeneric (setf stream-current-output-record) (record stream))
537
538 (defgeneric stream-add-output-record (stream record))
539
540 (defgeneric stream-replay (stream &optional region))
541
542 (defgeneric erase-output-record (record stream &optional (errorp t)))
543
544 (defgeneric copy-textual-output-history (window stream &optional region record))
545
546 (defmethod (setf stream-recording-p)
547 (recording-p (stream standard-output-recording-stream))
548 (let ((old-val (slot-value stream 'recording-p)))
549 (setf (slot-value stream 'recording-p) recording-p)
550 (when (not (eql old-val recording-p))
551 (stream-close-text-output-record stream))
552 recording-p))
553
554 ;;; 16.4.3 Text Output Recording
555
556 (defgeneric stream-text-output-record (stream text-style))
557
558 (defgeneric stream-close-text-output-record (stream))
559
560 (defgeneric stream-add-character-output
561 (stream character text-style width height baseline))
562
563 (defgeneric stream-add-string-output
564 (stream string start end text-style width height baseline))
565
566 ;;; Methods
567 (defmethod initialize-instance :after ((stream output-recording-stream) &rest args)
568 (declare (ignore args))
569 (setf (stream-current-output-record stream) (stream-output-history stream)))
570
571 (defmethod stream-add-output-record ((stream output-recording-stream) record)
572 (add-output-record record (stream-current-output-record stream)))
573
574 (defmethod stream-replay ((stream output-recording-stream) &optional region)
575 (replay (stream-output-history stream) stream region))
576
577 (defmacro with-output-recording-options ((stream
578 &key (record nil record-supplied-p)
579 (draw nil draw-supplied-p))
580 &body body)
581 (declare (type symbol stream))
582 (when (eq stream 't)
583 (setq stream '*standard-output*))
584 (let ((continuation-name (gensym "WITH-OUTPUT-RECORDING-OPTIONS")))
585 `(flet ((,continuation-name (,stream) ,@body))
586 (declare (dynamic-extent #',continuation-name))
587 (invoke-with-output-recording-options ,stream
588 #',continuation-name
589 ,(if record-supplied-p
590 record
591 `(stream-recording-p
592 ,stream))
593 ,(if draw-supplied-p
594 draw
595 `(stream-drawing-p
596 ,stream))))))
597
598
599 (defmethod invoke-with-output-recording-options
600 ((stream output-recording-stream) continuation record draw)
601 "Calls CONTINUATION on STREAM enabling or disabling recording and drawing
602 according to the flags RECORD and DRAW."
603 (letf (((stream-recording-p stream) record)
604 ((stream-drawing-p stream) draw))
605 (funcall continuation stream)))
606
607 (defmacro with-new-output-record ((stream
608 &optional
609 (record-type 'standard-sequence-output-record)
610 (record nil record-supplied-p)
611 &rest initargs)
612 &body body)
613 "Creates a new output record of type RECORD-TYPE and then captures
614 the output of BODY into the new output record, and inserts the new
615 record into the current \"open\" output record assotiated with STREAM.
616 If RECORD is supplied, it is the name of a variable that will be
617 lexically bound to the new output record inside the body. INITARGS are
618 CLOS initargs that are passed to MAKE-INSTANCE when the new output
619 record is created.
620 It returns the created output record.
621 The STREAM argument is a symbol that is bound to an output
622 recording stream. If it is T, *STANDARD-OUTPUT* is used."
623 (declare (type symbol stream record))
624 (when (eq stream 't)
625 (setq stream '*standard-output*))
626 (unless record-supplied-p
627 (setq record (gensym)))
628 `(invoke-with-new-output-record
629 ,stream
630 #'(lambda (,stream ,record)
631 (declare (ignorable ,stream ,record))
632 ,@body)
633 ',record-type
634 ,@initargs))
635
636 (defmethod invoke-with-new-output-record ((stream output-recording-stream)
637 continuation record-type
638 &rest initargs
639 &key parent
640 &allow-other-keys)
641 (stream-close-text-output-record stream)
642 (unless parent
643 (setq parent (stream-current-output-record stream)))
644 (let ((new-record (apply #'make-instance record-type :parent parent initargs)))
645 (letf (((stream-current-output-record stream) new-record))
646 ;; Should we switch on recording? -- APD
647 (funcall continuation stream new-record)
648 (finish-output stream))
649 (stream-add-output-record stream new-record)
650 new-record))
651
652 (defmacro with-output-to-output-record
653 ((stream
654 &optional
655 (record-type 'standard-sequence-output-record)
656 (record nil record-supplied-p)
657 &rest initargs)
658 &body body)
659 "Creates a new output record of type RECORD-TYPE and then captures
660 the output of BODY into the new output record. The cursor position of
661 STREAM is initially bound to (0,0)
662 If RECORD is supplied, it is the name of a variable that will be
663 lexically bound to the new output record inside the body. INITARGS are
664 CLOS initargs that are passed to MAKE-INSTANCE when the new output
665 record is created.
666 It returns the created output record.
667 The STREAM argument is a symbol that is bound to an output
668 recording stream. If it is T, *STANDARD-OUTPUT* is used."
669 (when (eq stream 't)
670 (setq stream '*standard-output*))
671 (check-type stream symbol)
672 (unless record-supplied-p (setq record (gensym "RECORD")))
673 `(invoke-with-output-to-output-record
674 ,stream
675 #'(lambda (,stream ,record)
676 (declare (ignorable ,stream ,record))
677 ,@body)
678 ',record-type
679 ,@initargs))
680
681 (defmethod invoke-with-output-to-output-record
682 ((stream output-recording-stream)
683 continuation record-type
684 &rest initargs
685 &key parent
686 &allow-other-keys)
687 (stream-close-text-output-record stream)
688 (unless parent (setq parent (stream-current-output-record stream)))
689 (let ((new-record (apply #'make-instance record-type
690 :parent parent initargs)))
691 (with-output-recording-options (stream :record t :draw nil)
692 (multiple-value-bind (cx cy)
693 (stream-cursor-position stream)
694 (unwind-protect
695 (letf (((stream-current-output-record stream) new-record))
696 (setf (stream-cursor-position stream) (values 0 0))
697 (funcall continuation stream new-record)
698 (finish-output stream))
699 (setf (stream-cursor-position stream) (values cx cy)))))
700 new-record))
701
702 (defmethod scroll-vertical :around ((stream output-recording-stream) dy)
703 (declare (ignore dy))
704 (with-output-recording-options (stream :record nil)
705 (declare (ignore stream))
706 (call-next-method)))
707
708 (defmethod scroll-horizontal :around ((stream output-recording-stream) dx)
709 (declare (ignore dx))
710 (with-output-recording-options (stream :record nil)
711 (declare (ignore stream))
712 (call-next-method)))
713
714 (defmethod handle-repaint ((stream output-recording-stream) region)
715 (stream-replay stream region))
716
717 #|
718 (defmethod handle-event :after ((stream output-recording-stream) (event pointer-button-press-event))
719 (highlight-output-record (stream-current-output-record stream) stream :highlight))
720
721 (defmethod handle-event :before ((stream output-recording-stream) (event pointer-button-release-event))
722 (highlight-output-record (stream-current-output-record stream) stream :unhighlight))
723 |#
724
725
726 ;;; Graphics and text recording classes
727
728 (eval-when (:compile-toplevel :load-toplevel :execute)
729
730 (defun compute-class-vars (names)
731 (cons (list 'stream :initarg :stream)
732 (loop for name in names
733 collecting (list name :initarg (intern (symbol-name name)
734 :keyword)))))
735
736 (defun compute-arg-list (names)
737 (loop for name in names
738 nconcing (list (intern (symbol-name name) :keyword) name)))
739 )
740
741 (defmacro def-grecording (name (&rest args) &body body)
742 (let ((method-name (intern (format nil "MEDIUM-~A*" name)))
743 (class-name (intern (format nil "~A-OUTPUT-RECORD" name)))
744 (medium (gensym "MEDIUM"))
745 (border (gensym "BORDER")))
746 `(progn
747 (defclass ,class-name (graphics-displayed-output-record-mixin)
748 ,(compute-class-vars args))
749 (defmethod initialize-instance :after ((graphic ,class-name) &rest args)
750 (declare (ignore args))
751 (with-slots (x y x1 y1 x2 y2 initial-x1 initial-y1
752 stream ink clipping-region transform
753 line-style text-style
754 ,@args) graphic
755 (let ((,border (1+ (/ (line-style-thickness line-style) 2))))
756 (multiple-value-bind (lf tp rt bt) (progn ,@body)
757 (setq x1 (- lf ,border)
758 y1 (- tp ,border)
759 x2 (+ rt ,border)
760 y2 (+ bt ,border))))
761 (setf x x1
762 y y1
763 initial-x1 x1
764 initial-y1 y1)))
765 (defmethod ,method-name :around ((stream output-recording-stream) ,@args)
766 (with-sheet-medium (medium stream)
767 (when (stream-recording-p stream)
768 (let ((record (make-instance ',class-name
769 :stream stream
770 :ink (medium-ink medium)
771 :clipping-region (medium-clipping-region medium)
772 :transformation (medium-transformation medium)
773 :line-style (medium-line-style medium)
774 :text-style (medium-text-style medium)
775 ,@(compute-arg-list args))))
776 (stream-add-output-record stream record)))
777 (when (stream-drawing-p stream)
778 (call-next-method))))
779 (defmethod replay-output-record ((record ,class-name) stream
780 &optional (region +everywhere+)
781 (x-offset 0) (y-offset 0))
782 (with-slots (x y initial-x1 initial-y1
783 ink clip transform line-style text-style ,@args) record
784 (let ((transformation (compose-translation-with-transformation
785 transform
786 (+ (- x initial-x1) x-offset)
787 (+ (- y initial-y1) y-offset)))
788 (,medium (sheet-medium stream))
789 ;; is sheet a sheet-with-medium-mixin? --GB
790 )
791 (letf (((medium-ink ,medium) ink)
792 ((medium-transformation ,medium) transformation)
793 ((medium-clipping-region ,medium)
794 (region-intersection clip
795 (untransform-region transformation
796 region)))
797 ((medium-line-style ,medium) line-style)
798 ((medium-text-style ,medium) text-style))
799 (,method-name ,medium ,@args))))))))
800
801 (def-grecording draw-point (point-x point-y)
802 (with-transformed-position (transform point-x point-y)
803 (values point-x point-y point-x point-y)))
804
805 (def-grecording draw-points (coord-seq)
806 (with-transformed-positions (transform coord-seq)
807 (loop for (x y) on coord-seq by #'cddr
808 minimize x into min-x
809 minimize y into min-y
810 maximize x into max-x
811 maximize y into max-y
812 finally (return (values min-x min-y max-x max-y)))))
813
814 (def-grecording draw-line (point-x1 point-y1 point-x2 point-y2)
815 (with-transformed-position (transform point-x1 point-y1)
816 (with-transformed-position (transform point-x2 point-y2)
817 (values (min point-x1 point-x2) (min point-y1 point-y2)
818 (max point-x1 point-x2) (max point-y1 point-y2)))))
819
820 (def-grecording draw-lines (coord-seq)
821 (with-transformed-positions (transform coord-seq)
822 (loop for (x y) on coord-seq by #'cddr
823 minimize x into min-x
824 minimize y into min-y
825 maximize x into max-x
826 maximize y into max-y
827 finally (return (values min-x min-y max-x max-y)))))
828
829 (def-grecording draw-polygon (coord-seq closed filled)
830 ;; FIXME !!!
831 ;; If LINE-STYLE-JOINT-SHAPE is :MITTER, then the bb is larger than
832 ;; these numbers by (LINE-THICKNESS / (sin (angle / 2))),
833 ;; which is larger than LINE-THICKNESS
834 (with-transformed-positions (transform coord-seq)
835 (loop for (x y) on coord-seq by #'cddr
836 minimize x into min-x
837 minimize y into min-y
838 maximize x into max-x
839 maximize y into max-y
840 finally (return (values min-x min-y max-x max-y)))))
841
842 (def-grecording draw-rectangle (left top right bottom filled)
843 ;; FIXME!!! If the rectangle is a line/point, MAKE-RECTANGLE* gives +NOWHERE+,
844 ;; and BOUNDING-RECTANGLE* signals an error.
845 (bounding-rectangle* (transform-region transform
846 (make-rectangle* left top right bottom))))
847
848 (def-grecording draw-ellipse (center-x center-y
849 radius-1-dx radius-1-dy radius-2-dx radius-2-dy
850 start-angle end-angle filled)
851 (bounding-rectangle* (transform-region transform
852 (make-ellipse* center-x center-y
853 radius-1-dx radius-1-dy radius-2-dx radius-2-dy
854 :start-angle start-angle
855 :end-angle end-angle))))
856
857 (def-grecording draw-text (string point-x point-y start end
858 align-x align-y toward-x toward-y transform-glyphs)
859 ;; FIXME!!! transformation
860 ;; Multiple lines?
861 (let* ((width (stream-string-width stream string
862 :start start :end end
863 :text-style text-style))
864 (ascent (text-style-ascent text-style (sheet-medium stream)))
865 (descent (text-style-descent text-style (sheet-medium stream)))
866 (height (+ ascent descent))
867 left top right bottom)
868 (ecase align-x
869 (:left (setq left point-x
870 right (+ point-x width)))
871 (:right (setq left (- point-x width)
872 right point-x))
873 (:center (setq left (- point-x (round width 2))
874 right (+ point-x (round width 2)))))
875 (ecase align-y
876 (:baseline (setq top (- point-y ascent)
877 bottom (+ point-y descent)))
878 (:top (setq top point-y
879 bottom (+ point-y height)))
880 (:bottom (setq top (- point-y height)
881 bottom point-y))
882 (:center (setq top (- point-y (floor height 2))
883 bottom (+ point-y (ceiling height 2)))))
884 (values left top right bottom)))
885
886
887 ;;; Text recording class
888
889 (defclass text-displayed-output-record (displayed-output-record)
890 ())
891
892 (defclass text-displayed-output-record-mixin
893 (text-displayed-output-record displayed-output-record-mixin)
894 ((strings :initform nil)
895 (baseline :initform 0)
896 (width :initform 0)
897 (max-height :initform 0)
898 (start-x :initarg :start-x)
899 (start-y :initarg :start-y)
900 (end-x)
901 (end-y)
902 (wrapped :initform nil
903 :accessor text-record-wrapped)))
904
905 (defun text-displayed-output-record-p (x)
906 (typep x 'text-displayed-output-record))
907
908 (defmethod print-object ((self text-displayed-output-record-mixin) stream)
909 (print-unreadable-object (self stream :type t :identity t)
910 (if (slot-boundp self 'start-x)
911 (with-slots (start-x start-y strings) self
912 (format stream "~D,~D ~S" start-x start-y (mapcar #'third strings)))
913 (format stream "empty"))))
914
915 (defgeneric add-character-output-to-text-record
916 (text-record character text-style width height baseline))
917 (defgeneric add-string-output-to-text-record
918 (text-record string start end text-style width height baseline))
919 (defgeneric text-displayed-output-record-string (text-record))
920
921 ;;; Methods
922 (defmethod tree-recompute-extent
923 ((text-record text-displayed-output-record-mixin))
924 (with-slots (parent x y
925 x1 y1 x2 y2 width max-height) text-record
926 (setq x1 (coordinate x)
927 y1 (coordinate y)
928 x2 (coordinate (+ x width))
929 y2 (coordinate (+ y max-height)))))
930
931 (defmethod* (setf output-record-position) :before
932 (nx ny (record text-displayed-output-record-mixin))
933 (with-slots (x1 y1 x2 y2 x y start-x start-y end-x end-y) record
934 (let ((dx (- nx x))
935 (dy (- ny y)))
936 (incf start-x dx)
937 (incf start-y dy)
938 (incf end-x dx)
939 (incf end-y dy))))
940
941 (defmethod add-character-output-to-text-record ((text-record text-displayed-output-record-mixin)
942 character text-style char-width height
943 new-baseline)
944 (with-slots (strings baseline width max-height start-y end-x end-y) text-record
945 (if (and strings (eq (second (first (last strings))) text-style))
946 (vector-push-extend character (third (first (last strings))))
947 (setq strings (nconc strings (list (list end-x text-style (make-array 1 :initial-element character :element-type 'character :adjustable t :fill-pointer t))))))
948 (setq baseline (max baseline new-baseline)
949 end-x (+ end-x char-width)
950 max-height (max max-height height)
951 end-y (max end-y (+ start-y max-height))
952 width (+ width char-width)))
953 (tree-recompute-extent text-record))
954
955 (defmethod add-string-output-to-text-record ((text-record text-displayed-output-record-mixin)
956 string start end text-style string-width height
957 new-baseline)
958 (if end
959 (setq end (min end (1- (length string))))
960 (setq end (1- (length string))))
961 (let ((length (max 0 (- (1+ end) start))))
962 (cond
963 ((= length 1)
964 (add-character-output-to-text-record text-record (aref string start) text-style string-width height new-baseline))
965 (t
966 (setq string (make-array length :displaced-to string
967 :displaced-index-offset start
968 :element-type (array-element-type string)))
969 (with-slots (strings baseline width max-height start-y end-x end-y) text-record
970 (setq baseline (max baseline new-baseline)
971 strings (nconc strings
972 (list (list end-x text-style
973 (make-array (length string)
974 :initial-contents string
975 :element-type 'character
976 :adjustable t
977 :fill-pointer t))))
978 end-x (+ end-x string-width)
979 max-height (max max-height height)
980 end-y (max end-y (+ start-y max-height))
981 width (+ width string-width)))
982 (tree-recompute-extent text-record)))))
983
984 (defmethod replay-output-record ((record text-displayed-output-record-mixin)
985 stream
986 &optional region (x-offset 0) (y-offset 0))
987 (declare (ignore region))
988 (with-slots (strings baseline max-height start-x start-y wrapped
989 x y x1 y1 initial-x1 initial-y1) record
990 (let ((old-medium (sheet-medium stream))
991 (new-medium (make-medium (port stream) stream)))
992 (unwind-protect
993 (progn
994 (setf (%sheet-medium stream) new-medium) ;is sheet a sheet-with-medium-mixin? --GB
995 (setf (%medium-sheet new-medium) stream) ;is medium a basic medium?
996 (setf (medium-transformation new-medium)
997 (make-translation-transformation
998 x-offset
999 y-offset))
1000
1001 (setf (stream-cursor-position stream) (values start-x start-y))
1002 (letf (((slot-value stream 'baseline) baseline))
1003 (loop for (x text-style string) in strings
1004 do (setf (medium-text-style new-medium) text-style)
1005 (setf (stream-cursor-position stream)
1006 (values (+ x (- x1 initial-x1)) start-y))
1007 (stream-write-line stream string)))
1008 ;; clipping region
1009 #|restore cursor position? set to (end-x,end-y)?|#
1010 #+nil(loop for y = (+ start-y baseline)
1011 for (x text-style string) in strings
1012 do (setf (medium-text-style new-medium) text-style)
1013 (draw-text* (sheet-medium stream) string x y
1014 :text-style text-style :clipping-region (untransform-region (medium-transformation new-medium) region)))
1015 (if wrapped
1016 (draw-rectangle* (sheet-medium stream)
1017 (+ wrapped 0) start-y (+ wrapped 4) (+ start-y max-height)
1018 :ink +foreground-ink+
1019 :filled t)))
1020 (setf (%sheet-medium stream) old-medium))))) ;is sheet a sheet-with-medium-mixin? --GB
1021
1022 (defmethod output-record-start-cursor-position
1023 ((record text-displayed-output-record-mixin))
1024 (with-slots (start-x start-y) record
1025 (values start-x start-y)))
1026
1027 (defmethod output-record-end-cursor-position
1028 ((record text-displayed-output-record-mixin))
1029 (with-slots (end-x end-y) record
1030 (values end-x end-y)))
1031
1032 (defmethod text-displayed-output-record-string
1033 ((record text-displayed-output-record-mixin))
1034 (with-slots (strings) record
1035 (loop for result = ""
1036 for s in strings
1037 do (setq result (concatenate 'string result (third s)))
1038 finally (return result))))
1039
1040
1041 (defclass stream-text-record (text-displayed-output-record-mixin)
1042 ())
1043
1044 ;;; Methods for text output to output recording streams
1045 (defmethod stream-text-output-record ((stream standard-output-recording-stream) text-style)
1046 (declare (ignore text-style))
1047 (let ((record (stream-current-text-output-record stream)))
1048 (unless record
1049 (setf (stream-current-text-output-record stream)
1050 (setq record (make-instance 'stream-text-record)))
1051 (with-slots (start-x start-y end-x end-y x1 y1 x2 y2 x y
1052 initial-x1 initial-y1) record
1053 (multiple-value-bind (cx cy) (stream-cursor-position stream)
1054 (setq start-x cx
1055 start-y cy
1056 end-x start-x
1057 end-y start-y
1058 x1 (coordinate start-x)
1059 x2 (coordinate end-x)
1060 y1 (coordinate start-y)
1061 y2 (coordinate end-y)
1062 initial-x1 x1
1063 initial-y1 y1
1064 x start-x
1065 y start-y))))
1066 record))
1067
1068 (defmethod stream-close-text-output-record ((stream standard-output-recording-stream))
1069 (let ((record (stream-current-text-output-record stream)))
1070 (when record
1071 (setf (stream-current-text-output-record stream) nil)
1072 #|record stream-current-cursor-position to (end-x record) - already done|#
1073 (stream-add-output-record stream record))))
1074
1075 (defmethod stream-add-character-output ((stream standard-output-recording-stream)
1076 character text-style
1077 width height baseline)
1078 (add-character-output-to-text-record (stream-text-output-record stream text-style)
1079 character text-style width height baseline))
1080
1081 (defmethod stream-add-string-output ((stream standard-output-recording-stream)
1082 string start end text-style
1083 width height baseline)
1084 (add-string-output-to-text-record (stream-text-output-record stream text-style)
1085 string start end text-style
1086 width height baseline))
1087
1088 (defmacro without-local-recording (stream &body body)
1089 `(letf (((slot-value ,stream 'local-record-p) nil))
1090 ,@body))
1091
1092 (defmethod stream-write-line :around ((stream standard-output-recording-stream) line)
1093 (when (and (stream-recording-p stream)
1094 (slot-value stream 'local-record-p))
1095 (let* ((medium (sheet-medium stream))
1096 (text-style (medium-text-style medium)))
1097 (stream-add-string-output stream line 0 nil text-style
1098 (stream-string-width stream line
1099 :text-style text-style)
1100 (text-style-height text-style medium)
1101 (text-style-ascent text-style medium))))
1102 (when (stream-drawing-p stream)
1103 (without-local-recording stream
1104 (call-next-method))))
1105
1106 #+nil
1107 (defmethod stream-write-char :around ((stream standard-output-recording-stream) char)
1108 (when (and (stream-recording-p stream)
1109 (slot-value stream 'local-record-p))
1110 (if (or (eql char #\return)
1111 (eql char #\newline))
1112 (stream-close-text-output-record stream)
1113 (let* ((medium (sheet-medium stream))
1114 (text-style (medium-text-style medium)))
1115 (stream-add-character-output stream char text-style
1116 (stream-character-width stream char :text-style text-style)
1117 (text-style-height text-style medium)
1118 (text-style-ascent text-style medium)))))
1119 (without-local-recording stream
1120 (call-next-method)))
1121
1122 #+nil
1123 (defmethod stream-write-string :around ((stream standard-output-recording-stream) string
1124 &optional (start 0) end)
1125 ;; Problem: it is necessary to check for line wrapping. Now the
1126 ;; default method for STREAM-WRITE-STRING do char-by-char output,
1127 ;; therefore STREAM-WRITE-CHAR can do the right thing.
1128 (when (and (stream-recording-p stream)
1129 (slot-value stream 'local-record-p))
1130 (let* ((medium (sheet-medium stream))
1131 (text-style (medium-text-style medium)))
1132 (stream-add-string-output stream string start end text-style
1133 (stream-string-width stream string
1134 :start start :end end
1135 :text-style text-style)
1136 (text-style-height text-style medium)
1137 (text-style-ascent text-style medium))))
1138 (without-local-recording stream
1139 (call-next-method)))
1140
1141
1142 (defmethod stream-finish-output :after ((stream standard-output-recording-stream))
1143 (stream-close-text-output-record stream))
1144
1145 (defmethod stream-force-output :after ((stream standard-output-recording-stream))
1146 (stream-close-text-output-record stream))
1147
1148 (defmethod stream-terpri :after ((stream standard-output-recording-stream))
1149 (stream-close-text-output-record stream))
1150
1151 (defmethod* (setf stream-cursor-position) :after (x y (stream standard-output-recording-stream))
1152 (declare (ignore x y))
1153 (stream-close-text-output-record stream))
1154
1155 ;(defmethod stream-set-cursor-position :after ((stream standard-output-recording-stream))
1156 ; (stream-close-text-output-record stream))
1157
1158 (defmethod stream-wrap-line :before ((stream standard-output-recording-stream))
1159 (when (stream-recording-p stream)
1160 (setf (text-record-wrapped (stream-text-output-record stream nil)) ; FIXME!
1161 (stream-text-margin stream))))

  ViewVC Help
Powered by ViewVC 1.1.5