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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.27 - (show annotations)
Thu Oct 25 19:34:26 2001 UTC (12 years, 5 months ago) by mikemac
Branch: MAIN
Changes since 1.26: +3 -1 lines
displaced arrays need the same element type as the original array
1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 1998,1999,2000 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 ;;; 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 (defclass output-record-mixin ()
38 ((x :initarg :x-position
39 :initform 0
40 :type rational)
41 (y :initarg :y-position
42 :initform 0
43 :type rational)
44 (parent :initarg :parent
45 :initform nil
46 :reader output-record-parent)))
47
48 (defmethod initialize-instance :after ((record output-record-mixin) &rest args)
49 (declare (ignore args))
50 (with-slots (x1 y1 x2 y2) record
51 (setq x1 0
52 y1 0
53 x2 0
54 y2 0)))
55
56 (defclass output-record (standard-bounding-rectangle output-record-mixin)
57 ((children :initform nil
58 :reader output-record-children))
59 (:default-initargs :min-x 0 :min-y 0 :max-x 0 :max-y 0))
60
61 (defun output-record-p (x)
62 (typep x 'output-record))
63
64 (defclass displayed-output-record (standard-bounding-rectangle output-record-mixin)
65 ((ink :initarg :ink :reader displayed-output-record-ink)
66 (initial-x1 :initarg :initial-x1)
67 (initial-y1 :initarg :initial-y1)))
68
69 (defun displayed-output-record-p (x)
70 (typep x 'displayed-output-record))
71
72 ; 16.2.1. The Basic Output Record Protocol
73 (declaim (ftype (function (output-record) (values rational rational))
74 output-record-position))
75 (defgeneric output-record-position (record)
76 (:documentation
77 "Returns the x and y position of RECORD. The position is the
78 position of the upper-left corner of its bounding rectangle. The
79 position is relative to the stream, where (0,0) is (initially) the
80 upper-left corner of the stream."))
81
82 (defgeneric* (setf output-record-position) (x y record))
83
84 (declaim (ftype (function (output-record) (values integer integer))
85 output-record-start-cursor-position))
86 (defgeneric output-record-start-cursor-position (record)
87 (:documentation
88 "Returns the x and y starting cursor position of RECORD. The
89 positions are relative to the stream, where (0,0) is (initially) the
90 upper-left corner of the stream."))
91
92 (defgeneric* (setf output-record-start-cursor-position) (x y record))
93
94 (declaim (ftype (function (output-record) (values integer integer))
95 output-record-end-cursor-position))
96 (defgeneric output-record-end-cursor-position (record)
97 (:documentation
98 "Returns the x and y ending cursor position of RECORD. The
99 positions are relative to the stream, where (0,0) is (initially) the
100 upper-left corner of the stream."))
101
102 (defgeneric* (setf output-record-end-cursor-position) (x y record))
103
104 (defgeneric output-record-parent (record)
105 (:documentation
106 "Returns the output record that is the parent of RECORD, or nil if
107 RECORD has no parent."))
108
109 (defgeneric replay-output-record (record stream
110 &optional region x-offset y-offset)
111 (:documentation "Displays the output captured by RECORD on the
112 STREAM, exactly as it was originally captured. The current user
113 transformation, line style, text style, ink and clipping region of
114 STREAM are all ignored. Instead, these are gotten from the output
115 record.
116
117 Only those records that overlap REGION are displayed."))
118
119 (defgeneric output-record-hit-detection-rectangle* (record))
120
121 (defgeneric output-record-refined-position-test (record x y))
122
123 (defgeneric highlight-output-record (record stream state))
124
125 (defgeneric displayed-output-record-ink (displayed-output-record))
126
127 ; 16.2.2. Output Record "Database" Protocol
128
129 (defgeneric output-record-children (record))
130
131 (defgeneric add-output-record (child record))
132
133 (defgeneric delete-output-record (child record &optional (errorp t)))
134
135 (defgeneric clear-output-record (record))
136
137 (defgeneric output-record-count (record))
138
139 (defgeneric map-over-output-records-containing-position
140 (function record x y &optional x-offset y-offset &rest function-args))
141
142 (defgeneric map-over-output-records-overlapping-region
143 (function record region &optional x-offset y-offset &rest function-args))
144
145 ; 16.2.3. Output Record Change Notification Protocol
146
147 (defgeneric recompute-extent-for-new-child (record child))
148
149 (defgeneric recompute-extent-for-changed-child
150 (record child old-min-x old-min-y old-max-x old-max-y))
151
152 (defgeneric tree-recompute-extent (record))
153
154 ;;; Methods
155
156 (defmethod initialize-instance :after ((record output-record) &rest args
157 &key size
158 &allow-other-keys)
159 (declare (ignore args size)))
160
161 (defmethod output-record-position ((record output-record-mixin))
162 (with-slots (x y) record
163 (values x y)))
164
165 (defmethod* (setf output-record-position) (nx ny (record output-record-mixin))
166 (with-slots (x y x1 y1 x2 y2) record
167 (let ((dx (- nx x))
168 (dy (- ny y)))
169 (incf x1 dx) (incf y1 dy)
170 (incf x2 dx) (incf y2 dy))
171 (setq x nx
172 y ny)))
173
174 (defmethod* (setf output-record-position) :before (nx ny (record output-record))
175 (multiple-value-bind (old-x old-y) (output-record-position record)
176 (loop with dx = (- nx old-x)
177 and dy = (- ny old-y)
178 for child in (output-record-children record)
179 do (multiple-value-bind (x y) (output-record-position child)
180 (setf (output-record-position child) (values (+ x dx) (+ y dy)))))))
181
182 (defmethod* (setf output-record-position) :around (nx ny (record output-record-mixin))
183 (declare (ignore nx ny))
184 (with-bounding-rectangle* (min-x min-y max-x max-y) record
185 (call-next-method)
186 (let ((parent (output-record-parent record)))
187 (when parent
188 (recompute-extent-for-changed-child parent record
189 min-x min-y max-x max-y)))))
190
191 (defmethod output-record-start-cursor-position ((record displayed-output-record))
192 (values nil nil))
193
194 (defmethod* (setf output-record-start-cursor-position) (x y (record displayed-output-record))
195 (declare (ignore x y))
196 nil)
197
198 (defmethod output-record-end-cursor-position ((record displayed-output-record))
199 (values nil nil))
200
201 (defmethod* (setf output-record-end-cursor-position) (x y (record displayed-output-record))
202 (declare (ignore x y))
203 nil)
204
205 (defun replay (record stream &optional region)
206 (stream-close-text-output-record stream)
207 (when (stream-drawing-p stream)
208 (with-cursor-off stream
209 (multiple-value-bind (cx cy) (stream-cursor-position stream)
210 (unwind-protect
211 (letf (((stream-recording-p stream) nil))
212 (replay-output-record record stream region))
213 (setf (stream-cursor-position stream) (values cx cy)))))))
214
215 (defmethod replay-output-record ((record output-record) stream
216 &optional region (x-offset 0) (y-offset 0))
217 (when (null region)
218 (setq region +everywhere+))
219 (map-over-output-records-overlaping-region
220 #'replay-output-record record region x-offset y-offset
221 stream region x-offset y-offset))
222
223 (defmethod erase-output-record ((record output-record) stream &optional (errorp t))
224 (declare (ignore stream))
225 nil)
226
227 (defmethod output-record-hit-detection-rectangle* ((record output-record-mixin))
228 (bounding-rectangle* record))
229
230 (defmethod output-record-refined-sensitivity-test ((record output-record-mixin) x y)
231 (declare (ignore x y))
232 t)
233
234 (defmethod highlight-output-record ((record output-record-mixin) stream state)
235 (multiple-value-bind (x1 y1 x2 y2) (output-record-hit-detection-rectangle* record)
236 (ecase state
237 (:highlight
238 (draw-rectangle* (sheet-medium stream) x1 y1 x2 y2 :filled nil :ink +foreground-ink+))
239 (:unhighlight
240 (draw-rectangle* (sheet-medium stream) x1 y1 x2 y2 :filled nil :ink +background-ink+)))))
241
242 (defclass standard-sequence-output-record (output-record)
243 (
244 ))
245
246 (defclass standard-tree-output-record (output-record)
247 (
248 ))
249
250 (defmethod* (setf output-record-position) (nx ny (record standard-sequence-output-record))
251 (with-slots (x y) record
252 (setq x nx
253 y ny)))
254
255 (defmethod output-record-children ((output-record output-record))
256 (with-slots (children) output-record
257 (reverse children)))
258
259 (defmethod add-output-record (child (record output-record))
260 (with-slots (children) record
261 (push child children))
262 (with-slots (parent) child
263 (setf parent record)))
264
265 (defmethod add-output-record :before (child (record output-record))
266 (when (null (output-record-children record))
267 (with-bounding-rectangle* (min-x min-y max-x max-y) child
268 (with-slots (x1 y1 x2 y2) record
269 (setq x1 min-x
270 y1 min-y
271 x2 max-x
272 y2 max-y)))))
273
274 (defmethod add-output-record :after (child (record output-record))
275 (recompute-extent-for-new-child record child))
276
277 (defmethod delete-output-record (child (record output-record) &optional (errorp t))
278 (with-slots (children) record
279 (if (and errorp
280 (not (member child children)))
281 (error "~S is not a child of ~S" child record))
282 (setq children (delete child children))))
283
284 (defmethod delete-output-record :after (child (record output-record) &optional (errorp t))
285 (declare (ignore errorp))
286 (with-bounding-rectangle* (x1 y1 x2 y2) child
287 (recompute-extent-for-changed-child record child x1 y1 x2 y2)))
288
289 (defmethod clear-output-record ((record output-record))
290 (with-slots (children x1 y1 x2 y2) record
291 (setq children nil
292 x1 (coordinate 0)
293 y1 (coordinate 0)
294 x2 (coordinate 0)
295 y2 (coordinate 0))))
296
297 (defmethod output-record-count ((record output-record))
298 (length (output-record-children record)))
299
300 (defmethod map-over-output-records-containing-position (function (record output-record) x y
301 &optional (x-offset 0) (y-offset 0)
302 &rest function-args)
303 (declare (dynamic-extent function)
304 (ignore x-offset y-offset))
305 (loop for child in (output-record-children record)
306 when (and (region-contains-position-p
307 (multiple-value-call #'make-bounding-rectangle
308 (output-record-hit-detection-rectangle* child))
309 x y)
310 (output-record-refined-sensitivity-test child x y))
311 do (apply function child function-args)))
312
313 (defmethod map-over-output-records-overlaping-region (function (record output-record) region
314 &optional (x-offset 0) (y-offset 0)
315 &rest function-args)
316 (declare (dynamic-extent function)
317 (ignore x-offset y-offset))
318 (loop for child in (output-record-children record)
319 do (when (region-intersects-region-p region child)
320 (apply function child function-args))))
321
322 (defmethod recompute-extent-for-new-child ((record output-record) child)
323 (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2) record
324 (with-slots (parent x1 y1 x2 y2) record
325 (with-bounding-rectangle* (x1-child y1-child x2-child y2-child) child
326 (setq x1 (min x1 x1-child)
327 y1 (min y1 y1-child)
328 x2 (max x2 x2-child)
329 y2 (max y2 y2-child)))
330 (when parent
331 (recompute-extent-for-changed-child parent record old-x1 old-y1 old-x2 old-y2)))))
332
333 (defmethod recompute-extent-for-changed-child :around ((record output-record) child
334 old-min-x old-min-y old-max-x old-max-y)
335 (declare (ignore child old-min-x old-min-y old-max-x old-max-y))
336 (let ((old-rectangle (multiple-value-call #'make-bounding-rectangle
337 (bounding-rectangle* record))))
338 (call-next-method)
339 (with-slots (parent x1 y1 x2 y2) record
340 (when (and parent (not (region-equal old-rectangle record)))
341 (recompute-extent-for-changed-child parent record x1 y1 x2 y2)))))
342
343 (defmethod recompute-extent-for-changed-child ((record output-record) changed-child
344 old-min-x old-min-y old-max-x old-max-y)
345 (with-slots (children x1 y1 x2 y2) record
346 (with-bounding-rectangle* (new-x1 new-y1 new-x2 new-y2) changed-child
347 (setq x1 (min x1 new-x1)
348 y1 (min y1 new-y1)
349 x2 (max x2 new-x2)
350 y2 (max y2 new-y2)))
351 (if (null children)
352 (clear-output-record record)
353 (when (or (coordinate= x1 old-min-x)
354 (coordinate= y1 old-min-y)
355 (coordinate= x2 old-max-x)
356 (coordinate= y2 old-max-y))
357 (with-bounding-rectangle* (left top right bottom) (first children)
358 (loop for child in (rest children)
359 do (with-bounding-rectangle* (x1-child y1-child x2-child y2-child) child
360 (setq left (min left x1-child)
361 top (min top y1-child)
362 right (max right x2-child)
363 bottom (max bottom y2-child))))
364 (setq x1 left
365 y1 top
366 x2 right
367 y2 bottom))))))
368
369 (defmethod tree-recompute-extent ((record output-record))
370 (with-slots (children x1 y1 x2 y2) record
371 (if (null children)
372 (setq x1 (coordinate 0)
373 y1 (coordinate 0)
374 x2 (coordinate 0)
375 y2 (coordinate 0))
376 (with-bounding-rectangle* (left top right bottom) (first children)
377 (loop for child in (rest children)
378 do (with-bounding-rectangle* (l1 t1 r1 b1) child
379 (setq left (min left l1 r1)
380 top (min top t1 b1)
381 right (max right l1 r1)
382 bottom (max bottom t1 b1))))
383 (setq x1 left
384 y1 top
385 x2 right
386 y2 bottom)))))
387
388 (defmethod tree-recompute-extent :around ((record output-record))
389 (let ((old-rectangle (multiple-value-call #'make-bounding-rectangle
390 (bounding-rectangle* record))))
391 (call-next-method)
392 (with-slots (parent x1 y1 x2 y2) record
393 (when (and parent (not (region-equal old-rectangle record)))
394 (recompute-extent-for-changed-child parent record x1 y1 x2 y2)))))
395
396
397 ;;; Graphics recording classes
398
399 (defclass graphics-displayed-output-record (displayed-output-record)
400 ((clip :initarg :clipping-region
401 :documentation "Clipping region in user coordinates.")
402 (transform :initarg :transformation)
403 (line-style :initarg :line-style)
404 (text-style :initarg :text-style)
405 ))
406
407 (defun graphics-displayed-output-record-p (x)
408 (typep x 'graphics-displayed-output-record))
409
410
411 ;;; stream-output-history-mixin class
412
413 (defclass stream-output-history-mixin ()
414 ())
415
416 (defclass standard-sequence-output-history (standard-sequence-output-record stream-output-history-mixin)
417 ())
418
419 (defclass standard-tree-output-history (standard-tree-output-record stream-output-history-mixin)
420 ())
421
422
423 ;;; Output-Recording-Stream class
424
425 (defclass output-recording-stream ()
426 ((recording-p :initform t :accessor stream-recording-p)
427 (drawing-p :initform t :accessor stream-drawing-p)
428 (output-history :initform (make-instance 'standard-tree-output-history)
429 :reader stream-output-history)
430 (current-output-record :accessor stream-current-output-record)
431 (current-text-output-record :initform nil :accessor stream-current-text-output-record)
432 (local-record-p :initform t
433 :documentation "This flag is used for dealing with streams outputting strings char-by-char.")))
434
435 (defun output-recording-stream-p (x)
436 (typep x 'output-recording-stream))
437
438 (defclass standard-output-recording-stream (output-recording-stream)
439 (
440 ))
441
442 ;;; 16.4.1 The Output Recording Stream Protocol
443 (defgeneric stream-recording-p (stream))
444
445 (defgeneric (setf stream-recording-p) (recording-p stream))
446
447 (defgeneric stream-drawing-p (stream))
448
449 (defgeneric (setf stream-drawing-p) (drawing-p stream))
450
451 (defgeneric stream-output-history (stream))
452
453 (defgeneric stream-current-output-record (stream))
454
455 (defgeneric (setf stream-current-output-record) (record stream))
456
457 (defgeneric stream-add-output-record (stream record))
458
459 (defgeneric stream-replay (stream &optional region))
460
461 (defgeneric erase-output-record (record stream &optional (errorp t)))
462
463 (defgeneric copy-textual-output-history (window stream &optional region record))
464
465 ;;; 16.4.3 Text Output Recording
466
467 (defgeneric stream-text-output-record (stream text-style))
468
469 (defgeneric stream-close-text-output-record (stream))
470
471 (defgeneric stream-add-character-output
472 (stream character text-style width height baseline))
473
474 (defgeneric stream-add-string-output
475 (stream string start end text-style width height baseline))
476
477 ;;; Methods
478 (defmethod initialize-instance :after ((stream output-recording-stream) &rest args)
479 (declare (ignore args))
480 (setf (stream-current-output-record stream) (stream-output-history stream)))
481
482 (defmethod stream-add-output-record ((stream output-recording-stream) record)
483 (add-output-record record (stream-current-output-record stream)))
484
485 (defmethod stream-replay ((stream output-recording-stream) &optional region)
486 (replay (stream-output-history stream) stream region))
487
488 (defmacro with-output-recording-options ((stream &key (record t) (draw t)) &body body)
489 (declare (type symbol stream))
490 (when (eq stream 't)
491 (setq stream '*standard-output*))
492 (let ((continuation-name (gensym)))
493 `(let ((,continuation-name #'(lambda (,stream) ,@body)))
494 (invoke-with-output-recording-options ,stream
495 ,continuation-name
496 ,record
497 ,draw))))
498
499 (defmethod invoke-with-output-recording-options
500 ((stream output-recording-stream) continuation record draw)
501 "Calls CONTINUATION on STREAM enabling or disabling recording and drawing
502 according to the flags RECORD and DRAW."
503 (declare (dynamic-extent continuation))
504 (with-slots (recording-p drawing-p) stream
505 (unless (eq recording-p record)
506 (stream-close-text-output-record stream))
507 (letf ((recording-p record)
508 (drawing-p draw))
509 (funcall continuation stream))))
510
511 (defmacro with-new-output-record ((stream
512 &optional
513 (record-type 'standard-sequence-output-record)
514 (record nil record-supplied-p)
515 &rest initargs)
516 &body body)
517 "Creates a new output record of type RECORD-TYPE and then captures
518 the output of BODY into the new output record, and inserts the new
519 record into the current \"open\" output record assotiated with STREAM.
520 If RECORD is supplied, it is the name of a variable that will be
521 lexically bound to the new output record inside the body. INITARGS are
522 CLOS initargs that are passed to MAKE-INSTANCE when the new output
523 record is created.
524 It returns the created output record.
525 The STREAM argument is a symbol that is bound to an output
526 recording stream. If it is T, *STANDARD-OUTPUT* is used."
527 (declare (type symbol stream record))
528 (when (eq stream 't)
529 (setq stream '*standard-output*))
530 (unless record-supplied-p
531 (setq record (gensym)))
532 `(invoke-with-new-output-record
533 ,stream
534 #'(lambda (,stream ,record)
535 ,@(unless record-supplied-p `((declare (ignore ,record))))
536 ,@body)
537 ',record-type
538 ,@initargs))
539
540 (defmethod invoke-with-new-output-record ((stream output-recording-stream)
541 continuation record-type
542 &rest initargs
543 &key parent)
544 (stream-close-text-output-record stream)
545 (unless parent
546 (setq parent (stream-current-output-record stream)))
547 (let ((new-record (apply #'make-instance record-type :parent parent initargs)))
548 (letf (((stream-current-output-record stream) new-record))
549 (funcall continuation stream new-record)
550 (finish-output stream))
551 (stream-add-output-record stream new-record)
552 new-record))
553
554 (defmethod scroll-vertical :around ((stream output-recording-stream) dy)
555 (declare (ignore dy))
556 (with-output-recording-options (stream :record nil)
557 (call-next-method)))
558
559 (defmethod scroll-horizontal :around ((stream output-recording-stream) dx)
560 (declare (ignore dx))
561 (with-output-recording-options (stream :record nil)
562 (call-next-method)))
563
564 (defmethod repaint-sheet ((stream output-recording-stream) region)
565 (stream-replay stream region))
566
567 (defmethod handle-event ((stream output-recording-stream) (event window-repaint-event))
568 (repaint-sheet stream (window-event-region event)))
569
570 (defmethod handle-event ((stream output-recording-stream) (event pointer-button-press-event))
571 (with-slots (button x y) event
572 (format *debug-io* "button ~D pressed at ~D,~D~%" button x y)))
573
574 #|
575 (defmethod handle-event :after ((stream output-recording-stream) (event pointer-button-press-event))
576 (highlight-output-record (stream-current-output-record stream) stream :highlight))
577
578 (defmethod handle-event :before ((stream output-recording-stream) (event pointer-button-release-event))
579 (highlight-output-record (stream-current-output-record stream) stream :unhighlight))
580 |#
581
582
583 ;;; Graphics and text recording classes
584
585 (eval-when (compile load eval)
586
587 (defun compute-class-vars (names)
588 (cons (list 'stream :initarg :stream)
589 (loop for name in names
590 collecting (list name :initarg (intern (symbol-name name) :keyword)))))
591
592 (defun compute-arg-list (names)
593 (loop for name in names
594 nconcing (list (intern (symbol-name name) :keyword) name)))
595 )
596
597 (defun make-merged-medium (sheet ink clip transform line-style text-style)
598 (let ((medium (make-medium (port sheet) sheet)))
599 (setf (medium-ink medium) ink)
600 ;; First set transformation, then clipping region!
601 (setf (medium-transformation medium) transform)
602 (setf (medium-clipping-region medium) clip)
603 (setf (medium-line-style medium) line-style)
604 (setf (medium-text-style medium) text-style)
605 medium))
606
607 (defmacro def-grecording (name (&rest args) &body body)
608 (let ((method-name (intern (format nil "MEDIUM-~A*" name)))
609 (class-name (intern (format nil "~A-OUTPUT-RECORD" name)))
610 (old-medium (gensym))
611 (new-medium (gensym))
612 (border (gensym)))
613 `(progn
614 (defclass ,class-name (graphics-displayed-output-record)
615 ,(compute-class-vars args))
616 (defmethod initialize-instance :after ((graphic ,class-name) &rest args)
617 (declare (ignore args))
618 (with-slots (x y x1 y1 x2 y2 initial-x1 initial-y1
619 stream ink clipping-region transform
620 line-style text-style
621 ,@args) graphic
622 (let ((,border (1+ (/ (line-style-thickness line-style) 2))))
623 (multiple-value-bind (lf tp rt bt) (progn ,@body)
624 (setq x1 (- lf ,border)
625 y1 (- tp ,border)
626 x2 (+ rt ,border)
627 y2 (+ bt ,border))))
628 (setf x x1
629 y y1
630 initial-x1 x1
631 initial-y1 y1)))
632 (defmethod ,method-name :around ((stream output-recording-stream) ,@args)
633 (with-sheet-medium (medium stream)
634 (when (stream-recording-p stream)
635 (let ((record (make-instance ',class-name
636 :stream stream
637 :ink (medium-ink medium)
638 :clipping-region (medium-clipping-region medium)
639 :transformation (medium-transformation medium)
640 :line-style (medium-line-style medium)
641 :text-style (medium-text-style medium)
642 ,@(compute-arg-list args))))
643 (stream-add-output-record stream record)))
644 (when (stream-drawing-p stream)
645 (call-next-method))))
646 (defmethod replay-output-record ((record ,class-name) stream
647 &optional (region +everywhere+)
648 (x-offset 0) (y-offset 0))
649 (with-slots (x y initial-x1 initial-y1
650 ink clip transform line-style text-style ,@args) record
651 (let ((transformation (compose-translation-with-transformation
652 transform
653 (+ (- x initial-x1) x-offset)
654 (+ (- y initial-y1) y-offset))))
655 (let ((,old-medium (sheet-medium stream))
656 (,new-medium (make-merged-medium stream ink
657 (region-intersection clip
658 (untransform-region transformation region))
659 transformation line-style text-style)))
660 (unwind-protect
661 (progn
662 (setf (sheet-medium stream) ,new-medium)
663 (setf (medium-sheet ,new-medium) stream)
664 (,method-name ,new-medium ,@args))
665 (setf (sheet-medium stream) ,old-medium)))))))))
666
667 (def-grecording draw-point (point-x point-y)
668 (with-transformed-position (transform point-x point-y)
669 (values point-x point-y point-x point-y)))
670
671 (def-grecording draw-points (coord-seq)
672 (with-transformed-positions (transform coord-seq)
673 (loop for (x y) on coord-seq by #'cddr
674 minimize x into min-x
675 minimize y into min-y
676 maximize x into max-x
677 maximize y into max-y
678 finally (return (values min-x min-y max-x max-y)))))
679
680 (def-grecording draw-line (point-x1 point-y1 point-x2 point-y2)
681 (with-transformed-position (transform point-x1 point-y1)
682 (with-transformed-position (transform point-x2 point-y2)
683 (values (min point-x1 point-x2) (min point-y1 point-y2)
684 (max point-x1 point-x2) (max point-y1 point-y2)))))
685
686 (def-grecording draw-lines (coord-seq)
687 (with-transformed-positions (transform coord-seq)
688 (loop for (x y) on coord-seq by #'cddr
689 minimize x into min-x
690 minimize y into min-y
691 maximize x into max-x
692 maximize y into max-y
693 finally (return (values min-x min-y max-x max-y)))))
694
695 (def-grecording draw-polygon (coord-seq closed filled)
696 ;; FIXME !!!
697 ;; If LINE-STYLE-JOINT-SHAPE is :MITTER, then the bb is larger than
698 ;; these numbers by (LINE-THICKNESS / (sin (angle / 2))),
699 ;; which is larger than LINE-THICKNESS
700 (with-transformed-positions (transform coord-seq)
701 (loop for (x y) on coord-seq by #'cddr
702 minimize x into min-x
703 minimize y into min-y
704 maximize x into max-x
705 maximize y into max-y
706 finally (return (values min-x min-y max-x max-y)))))
707
708 (def-grecording draw-rectangle (left top right bottom filled)
709 ;; FIXME!!! If the rectangle is a line/point, MAKE-RECTANGLE* gives +NOWHERE+,
710 ;; and BOUNDING-RECTANGLE* signals an error.
711 (bounding-rectangle* (transform-region transform
712 (make-rectangle* left top right bottom))))
713
714 (def-grecording draw-ellipse (center-x center-y
715 radius-1-dx radius-1-dy radius-2-dx radius-2-dy
716 start-angle end-angle filled)
717 (bounding-rectangle* (transform-region transform
718 (make-ellipse* center-x center-y
719 radius-1-dx radius-1-dy radius-2-dx radius-2-dy
720 :start-angle start-angle
721 :end-angle end-angle))))
722
723 (def-grecording draw-text (string point-x point-y start end
724 align-x align-y toward-x toward-y transform-glyphs)
725 ;; FIXME!!! transformation
726 (let* ((width (stream-string-width stream string
727 :start start :end end
728 :text-style text-style))
729 (ascent (text-style-ascent text-style (sheet-medium stream)))
730 (descent (text-style-descent text-style (sheet-medium stream)))
731 (height (+ ascent descent))
732 left top right bottom)
733 (ecase align-x
734 (:left (setq left point-x
735 right (+ point-x width)))
736 (:right (setq left (- point-x width)
737 right point-x))
738 (:center (setq left (- point-x (round width 2))
739 right (+ point-x (round width 2)))))
740 (ecase align-y
741 (:baseline (setq top (- point-y height)
742 bottom (+ point-y descent)))
743 (:top (setq top point-y
744 bottom (+ point-y height)))
745 (:bottom (setq top (- point-y height)
746 bottom point-y))
747 (:center (setq top (- point-y (floor height 2))
748 bottom (+ point-y (ceiling height 2)))))
749 (values left top right bottom)))
750
751
752 ;;; Text recording class
753
754 (defclass text-displayed-output-record (displayed-output-record)
755 ((strings :initform nil)
756 (baseline :initform 0)
757 (width :initform 0)
758 (max-height :initform 0)
759 (start-x :initarg :start-x)
760 (start-y :initarg :start-y)
761 (end-x)
762 (end-y)
763 (wrapped :initform nil
764 :accessor text-record-wrapped)))
765
766 (defun text-displayed-output-record-p (x)
767 (typep x 'text-displayed-output-record))
768
769 (defmethod print-object ((self text-displayed-output-record) stream)
770 (print-unreadable-object (self stream :type t :identity t)
771 (if (slot-boundp self 'start-x)
772 (with-slots (start-x start-y strings) self
773 (format stream "~D,~D ~S" start-x start-y (mapcar #'third strings)))
774 (format stream "empty"))))
775
776 (defgeneric add-character-output-to-text-record
777 (text-record character text-style width height baseline))
778 (defgeneric add-string-output-to-text-record
779 (text-record string start end text-style width height baseline))
780 (defgeneric text-displayed-output-record-string (text-record))
781
782 ;;; Methods
783 (defmethod tree-recompute-extent ((text-record text-displayed-output-record))
784 (with-slots (parent x y
785 x1 y1 x2 y2 width max-height) text-record
786 (setq x1 (coordinate x)
787 y1 (coordinate y)
788 x2 (coordinate (+ x width))
789 y2 (coordinate (+ y max-height)))))
790
791 (defmethod* (setf output-record-position) :before (nx ny (record text-displayed-output-record))
792 (with-slots (x1 y1 x2 y2 x y start-x start-y end-x end-y) record
793 (let ((dx (- nx x))
794 (dy (- ny y)))
795 (incf start-x dx)
796 (incf start-y dy)
797 (incf end-x dx)
798 (incf end-y dy))))
799
800 (defmethod add-character-output-to-text-record ((text-record text-displayed-output-record)
801 character text-style char-width height
802 new-baseline)
803 (with-slots (strings baseline width max-height start-y end-x end-y) text-record
804 (if (and strings (eq (second (first (last strings))) text-style))
805 (vector-push-extend character (third (first (last strings))))
806 (setq strings (nconc strings (list (list end-x text-style (make-array 1 :initial-element character :element-type 'character :adjustable t :fill-pointer t))))))
807 (setq baseline (max baseline new-baseline)
808 end-x (+ end-x char-width)
809 max-height (max max-height height)
810 end-y (max end-y (+ start-y max-height))
811 width (+ width char-width)))
812 (tree-recompute-extent text-record))
813
814 (defmethod add-string-output-to-text-record ((text-record text-displayed-output-record)
815 string start end text-style string-width height
816 new-baseline)
817 (if end
818 (setq end (min end (1- (length string))))
819 (setq end (1- (length string))))
820 (let ((length (max 0 (- (1+ end) start))))
821 (setq string (make-array length :displaced-to string
822 :displaced-index-offset start
823 :element-type (array-element-type string)))
824 (with-slots (strings baseline width max-height start-y end-x end-y) text-record
825 (setq baseline (max baseline new-baseline)
826 strings (nconc strings (list (list end-x text-style (make-array (length string) :initial-contents string :element-type 'character :adjustable t :fill-pointer t))))
827 end-x (+ end-x string-width)
828 max-height (max max-height height)
829 end-y (max end-y (+ start-y max-height))
830 width (+ width string-width))))
831 (tree-recompute-extent text-record))
832
833 (defmethod replay-output-record ((record text-displayed-output-record) stream
834 &optional region (x-offset 0) (y-offset 0))
835 (with-slots (strings baseline max-height start-x start-y wrapped
836 x y x1 y1 initial-x1 initial-y1) record
837 (let ((old-medium (sheet-medium stream))
838 (new-medium (make-medium (port stream) stream)))
839 (unwind-protect
840 (progn
841 (setf (sheet-medium stream) new-medium)
842 (setf (medium-sheet new-medium) stream)
843 (setf (medium-transformation new-medium)
844 (make-translation-transformation
845 x-offset
846 y-offset))
847
848 (setf (stream-cursor-position stream) (values start-x start-y))
849 (letf (((slot-value stream 'baseline) baseline))
850 (loop for (x text-style string) in strings
851 do (setf (medium-text-style new-medium) text-style)
852 (setf (stream-cursor-position stream)
853 (values (+ x (- x1 initial-x1)) start-y))
854 (stream-write-line stream string)))
855 ;; clipping region
856 #|restore cursor position? set to (end-x,end-y)?|#
857 #+nil(loop for y = (+ start-y baseline)
858 for (x text-style string) in strings
859 do (setf (medium-text-style new-medium) text-style)
860 (draw-text* (sheet-medium stream) string x y
861 :text-style text-style :clipping-region (untransform-region (medium-transformation new-medium) region)))
862 (if wrapped
863 (draw-rectangle* (sheet-medium stream)
864 (+ wrapped 0) start-y (+ wrapped 4) (+ start-y max-height)
865 :ink +foreground-ink+
866 :filled t)))
867 (setf (sheet-medium stream) old-medium)))))
868
869 (defmethod output-record-start-cursor-position ((record text-displayed-output-record))
870 (with-slots (start-x start-y) record
871 (values start-x start-y)))
872
873 (defmethod output-record-end-cursor-position ((record text-displayed-output-record))
874 (with-slots (end-x end-y) record
875 (values end-x end-y)))
876
877 (defmethod text-displayed-output-record-string ((record text-displayed-output-record))
878 (with-slots (strings) record
879 (loop for result = ""
880 for s in strings
881 do (setq result (concatenate 'string result (third s)))
882 finally (return result))))
883
884
885 ;;; Methods for text output to output recording streams
886 (defmethod stream-text-output-record ((stream standard-output-recording-stream) text-style)
887 (let ((record (stream-current-text-output-record stream)))
888 (unless record
889 (setf (stream-current-text-output-record stream)
890 (setq record (make-instance 'text-displayed-output-record)))
891 (with-slots (start-x start-y end-x end-y x1 y1 x2 y2 x y
892 initial-x1 initial-y1) record
893 (multiple-value-bind (cx cy) (stream-cursor-position stream)
894 (setq start-x cx
895 start-y cy
896 end-x start-x
897 end-y start-y
898 x1 (coordinate start-x)
899 x2 (coordinate end-x)
900 y1 (coordinate start-y)
901 y2 (coordinate end-y)
902 initial-x1 x1
903 initial-y1 y1
904 x start-x
905 y start-y))))
906 record))
907
908 (defmethod stream-close-text-output-record ((stream standard-output-recording-stream))
909 (let ((record (stream-current-text-output-record stream)))
910 (when record
911 (setf (stream-current-text-output-record stream) nil)
912 #|record stream-current-cursor-position to (end-x record) - already done|#
913 (stream-add-output-record stream record))))
914
915 (defmethod stream-add-character-output ((stream standard-output-recording-stream)
916 character text-style
917 width height baseline)
918 (add-character-output-to-text-record (stream-text-output-record stream text-style)
919 character text-style width height baseline))
920
921 (defmethod stream-add-string-output ((stream standard-output-recording-stream)
922 string start end text-style
923 width height baseline)
924 (add-string-output-to-text-record (stream-text-output-record stream text-style)
925 string start end text-style
926 width height baseline))
927
928 (defmacro without-local-recording (stream &body body)
929 `(letf (((slot-value ,stream 'local-record-p) nil))
930 ,@body))
931
932 (defmethod stream-write-line :around ((stream standard-output-recording-stream) line)
933 (when (and (stream-recording-p stream)
934 (slot-value stream 'local-record-p))
935 (let* ((medium (sheet-medium stream))
936 (text-style (medium-text-style medium)))
937 (stream-add-string-output stream line 0 nil text-style
938 (stream-string-width stream line
939 :text-style text-style)
940 (text-style-height text-style medium)
941 (text-style-ascent text-style medium))))
942 (when (stream-drawing-p stream)
943 (without-local-recording stream
944 (call-next-method))))
945
946 #+nil
947 (defmethod stream-write-char :around ((stream standard-output-recording-stream) char)
948 (when (and (stream-recording-p stream)
949 (slot-value stream 'local-record-p))
950 (if (or (eql char #\return)
951 (eql char #\newline))
952 (stream-close-text-output-record stream)
953 (let* ((medium (sheet-medium stream))
954 (text-style (medium-text-style medium)))
955 (stream-add-character-output stream char text-style
956 (stream-character-width stream char :text-style text-style)
957 (text-style-height text-style medium)
958 (text-style-ascent text-style medium)))))
959 (without-local-recording stream
960 (call-next-method)))
961
962 #+nil
963 (defmethod stream-write-string :around ((stream standard-output-recording-stream) string
964 &optional (start 0) end)
965 ;; Problem: it is necessary to check for line wrapping. Now the
966 ;; default method for STREAM-WRITE-STRING do char-by-char output,
967 ;; therefore STREAM-WRITE-CHAR can do the right thing.
968 (when (and (stream-recording-p stream)
969 (slot-value stream 'local-record-p))
970 (let* ((medium (sheet-medium stream))
971 (text-style (medium-text-style medium)))
972 (stream-add-string-output stream string start end text-style
973 (stream-string-width stream string
974 :start start :end end
975 :text-style text-style)
976 (text-style-height text-style medium)
977 (text-style-ascent text-style medium))))
978 (without-local-recording stream
979 (call-next-method)))
980
981
982 (defmethod stream-finish-output :after ((stream standard-output-recording-stream))
983 (stream-close-text-output-record stream))
984
985 (defmethod stream-force-output :after ((stream standard-output-recording-stream))
986 (stream-close-text-output-record stream))
987
988 (defmethod stream-terpri :after ((stream standard-output-recording-stream))
989 (stream-close-text-output-record stream))
990
991 (defmethod* (setf stream-cursor-position) :after (x y (stream standard-output-recording-stream))
992 (stream-close-text-output-record stream))
993
994 ;(defmethod stream-set-cursor-position :after ((stream standard-output-recording-stream))
995 ; (stream-close-text-output-record stream))
996
997 (defmethod stream-wrap-line :before ((stream standard-output-recording-stream))
998 (when (stream-recording-p stream)
999 (setf (text-record-wrapped (stream-text-output-record stream nil)) ; FIXME!
1000 (stream-text-margin stream))))

  ViewVC Help
Powered by ViewVC 1.1.5