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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.31 - (show annotations)
Tue Jan 1 20:14:12 2002 UTC (12 years, 3 months ago) by moore
Branch: MAIN
Changes since 1.30: +2 -1 lines
Rudimentary implementation of accept, with one accept method (for reals) and
an example.  Split views out into another file so that +textual-view+ can be
referenced in the streams code.
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 ;;; 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 #+:cmu(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 #+:cmu(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 #+:cmu(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 errorp))
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 &allow-other-keys)
545 (stream-close-text-output-record stream)
546 (unless parent
547 (setq parent (stream-current-output-record stream)))
548 (let ((new-record (apply #'make-instance record-type :parent parent initargs)))
549 (letf (((stream-current-output-record stream) new-record))
550 (funcall continuation stream new-record)
551 (finish-output stream))
552 (stream-add-output-record stream new-record)
553 new-record))
554
555 (defmethod scroll-vertical :around ((stream output-recording-stream) dy)
556 (declare (ignore dy))
557 (with-output-recording-options (stream :record nil)
558 (declare (ignore stream))
559 (call-next-method)))
560
561 (defmethod scroll-horizontal :around ((stream output-recording-stream) dx)
562 (declare (ignore dx))
563 (with-output-recording-options (stream :record nil)
564 (declare (ignore stream))
565 (call-next-method)))
566
567 (defmethod repaint-sheet ((stream output-recording-stream) region)
568 (stream-replay stream region))
569
570 (defmethod handle-event ((stream output-recording-stream) (event window-repaint-event))
571 (repaint-sheet stream (window-event-region event)))
572
573 (defmethod handle-event ((stream output-recording-stream) (event pointer-button-press-event))
574 (with-slots (button x y) event
575 (format *debug-io* "button ~D pressed at ~D,~D~%" button x y)))
576
577 #|
578 (defmethod handle-event :after ((stream output-recording-stream) (event pointer-button-press-event))
579 (highlight-output-record (stream-current-output-record stream) stream :highlight))
580
581 (defmethod handle-event :before ((stream output-recording-stream) (event pointer-button-release-event))
582 (highlight-output-record (stream-current-output-record stream) stream :unhighlight))
583 |#
584
585
586 ;;; Graphics and text recording classes
587
588 (eval-when (compile load eval)
589
590 (defun compute-class-vars (names)
591 (cons (list 'stream :initarg :stream)
592 (loop for name in names
593 collecting (list name :initarg (intern (symbol-name name) :keyword)))))
594
595 (defun compute-arg-list (names)
596 (loop for name in names
597 nconcing (list (intern (symbol-name name) :keyword) name)))
598 )
599
600 (defun make-merged-medium (sheet ink clip transform line-style text-style)
601 (let ((medium (make-medium (port sheet) sheet)))
602 (setf (medium-ink medium) ink)
603 ;; First set transformation, then clipping region!
604 (setf (medium-transformation medium) transform)
605 (setf (medium-clipping-region medium) clip)
606 (setf (medium-line-style medium) line-style)
607 (setf (medium-text-style medium) text-style)
608 medium))
609
610 (defmacro def-grecording (name (&rest args) &body body)
611 (let ((method-name (intern (format nil "MEDIUM-~A*" name)))
612 (class-name (intern (format nil "~A-OUTPUT-RECORD" name)))
613 (old-medium (gensym))
614 (new-medium (gensym))
615 (border (gensym)))
616 `(progn
617 (defclass ,class-name (graphics-displayed-output-record)
618 ,(compute-class-vars args))
619 (defmethod initialize-instance :after ((graphic ,class-name) &rest args)
620 (declare (ignore args))
621 (with-slots (x y x1 y1 x2 y2 initial-x1 initial-y1
622 stream ink clipping-region transform
623 line-style text-style
624 ,@args) graphic
625 (let ((,border (1+ (/ (line-style-thickness line-style) 2))))
626 (multiple-value-bind (lf tp rt bt) (progn ,@body)
627 (setq x1 (- lf ,border)
628 y1 (- tp ,border)
629 x2 (+ rt ,border)
630 y2 (+ bt ,border))))
631 (setf x x1
632 y y1
633 initial-x1 x1
634 initial-y1 y1)))
635 (defmethod ,method-name :around ((stream output-recording-stream) ,@args)
636 (with-sheet-medium (medium stream)
637 (when (stream-recording-p stream)
638 (let ((record (make-instance ',class-name
639 :stream stream
640 :ink (medium-ink medium)
641 :clipping-region (medium-clipping-region medium)
642 :transformation (medium-transformation medium)
643 :line-style (medium-line-style medium)
644 :text-style (medium-text-style medium)
645 ,@(compute-arg-list args))))
646 (stream-add-output-record stream record)))
647 (when (stream-drawing-p stream)
648 (call-next-method))))
649 (defmethod replay-output-record ((record ,class-name) stream
650 &optional (region +everywhere+)
651 (x-offset 0) (y-offset 0))
652 (with-slots (x y initial-x1 initial-y1
653 ink clip transform line-style text-style ,@args) record
654 (let ((transformation (compose-translation-with-transformation
655 transform
656 (+ (- x initial-x1) x-offset)
657 (+ (- y initial-y1) y-offset))))
658 (let ((,old-medium (sheet-medium stream))
659 (,new-medium (make-merged-medium stream ink
660 (region-intersection clip
661 (untransform-region transformation region))
662 transformation line-style text-style)))
663 (unwind-protect
664 (progn
665 (setf (sheet-medium stream) ,new-medium)
666 (setf (medium-sheet ,new-medium) stream)
667 (,method-name ,new-medium ,@args))
668 (setf (sheet-medium stream) ,old-medium)))))))))
669
670 (def-grecording draw-point (point-x point-y)
671 (with-transformed-position (transform point-x point-y)
672 (values point-x point-y point-x point-y)))
673
674 (def-grecording draw-points (coord-seq)
675 (with-transformed-positions (transform coord-seq)
676 (loop for (x y) on coord-seq by #'cddr
677 minimize x into min-x
678 minimize y into min-y
679 maximize x into max-x
680 maximize y into max-y
681 finally (return (values min-x min-y max-x max-y)))))
682
683 (def-grecording draw-line (point-x1 point-y1 point-x2 point-y2)
684 (with-transformed-position (transform point-x1 point-y1)
685 (with-transformed-position (transform point-x2 point-y2)
686 (values (min point-x1 point-x2) (min point-y1 point-y2)
687 (max point-x1 point-x2) (max point-y1 point-y2)))))
688
689 (def-grecording draw-lines (coord-seq)
690 (with-transformed-positions (transform coord-seq)
691 (loop for (x y) on coord-seq by #'cddr
692 minimize x into min-x
693 minimize y into min-y
694 maximize x into max-x
695 maximize y into max-y
696 finally (return (values min-x min-y max-x max-y)))))
697
698 (def-grecording draw-polygon (coord-seq closed filled)
699 ;; FIXME !!!
700 ;; If LINE-STYLE-JOINT-SHAPE is :MITTER, then the bb is larger than
701 ;; these numbers by (LINE-THICKNESS / (sin (angle / 2))),
702 ;; which is larger than LINE-THICKNESS
703 (with-transformed-positions (transform coord-seq)
704 (loop for (x y) on coord-seq by #'cddr
705 minimize x into min-x
706 minimize y into min-y
707 maximize x into max-x
708 maximize y into max-y
709 finally (return (values min-x min-y max-x max-y)))))
710
711 (def-grecording draw-rectangle (left top right bottom filled)
712 ;; FIXME!!! If the rectangle is a line/point, MAKE-RECTANGLE* gives +NOWHERE+,
713 ;; and BOUNDING-RECTANGLE* signals an error.
714 (bounding-rectangle* (transform-region transform
715 (make-rectangle* left top right bottom))))
716
717 (def-grecording draw-ellipse (center-x center-y
718 radius-1-dx radius-1-dy radius-2-dx radius-2-dy
719 start-angle end-angle filled)
720 (bounding-rectangle* (transform-region transform
721 (make-ellipse* center-x center-y
722 radius-1-dx radius-1-dy radius-2-dx radius-2-dy
723 :start-angle start-angle
724 :end-angle end-angle))))
725
726 (def-grecording draw-text (string point-x point-y start end
727 align-x align-y toward-x toward-y transform-glyphs)
728 ;; FIXME!!! transformation
729 (let* ((width (stream-string-width stream string
730 :start start :end end
731 :text-style text-style))
732 (ascent (text-style-ascent text-style (sheet-medium stream)))
733 (descent (text-style-descent text-style (sheet-medium stream)))
734 (height (+ ascent descent))
735 left top right bottom)
736 (ecase align-x
737 (:left (setq left point-x
738 right (+ point-x width)))
739 (:right (setq left (- point-x width)
740 right point-x))
741 (:center (setq left (- point-x (round width 2))
742 right (+ point-x (round width 2)))))
743 (ecase align-y
744 (:baseline (setq top (- point-y height)
745 bottom (+ point-y descent)))
746 (:top (setq top point-y
747 bottom (+ point-y height)))
748 (:bottom (setq top (- point-y height)
749 bottom point-y))
750 (:center (setq top (- point-y (floor height 2))
751 bottom (+ point-y (ceiling height 2)))))
752 (values left top right bottom)))
753
754
755 ;;; Text recording class
756
757 (defclass text-displayed-output-record (displayed-output-record)
758 ((strings :initform nil)
759 (baseline :initform 0)
760 (width :initform 0)
761 (max-height :initform 0)
762 (start-x :initarg :start-x)
763 (start-y :initarg :start-y)
764 (end-x)
765 (end-y)
766 (wrapped :initform nil
767 :accessor text-record-wrapped)))
768
769 (defun text-displayed-output-record-p (x)
770 (typep x 'text-displayed-output-record))
771
772 (defmethod print-object ((self text-displayed-output-record) stream)
773 (print-unreadable-object (self stream :type t :identity t)
774 (if (slot-boundp self 'start-x)
775 (with-slots (start-x start-y strings) self
776 (format stream "~D,~D ~S" start-x start-y (mapcar #'third strings)))
777 (format stream "empty"))))
778
779 (defgeneric add-character-output-to-text-record
780 (text-record character text-style width height baseline))
781 (defgeneric add-string-output-to-text-record
782 (text-record string start end text-style width height baseline))
783 (defgeneric text-displayed-output-record-string (text-record))
784
785 ;;; Methods
786 (defmethod tree-recompute-extent ((text-record text-displayed-output-record))
787 (with-slots (parent x y
788 x1 y1 x2 y2 width max-height) text-record
789 (setq x1 (coordinate x)
790 y1 (coordinate y)
791 x2 (coordinate (+ x width))
792 y2 (coordinate (+ y max-height)))))
793
794 (defmethod* (setf output-record-position) :before (nx ny (record text-displayed-output-record))
795 (with-slots (x1 y1 x2 y2 x y start-x start-y end-x end-y) record
796 (let ((dx (- nx x))
797 (dy (- ny y)))
798 (incf start-x dx)
799 (incf start-y dy)
800 (incf end-x dx)
801 (incf end-y dy))))
802
803 (defmethod add-character-output-to-text-record ((text-record text-displayed-output-record)
804 character text-style char-width height
805 new-baseline)
806 (with-slots (strings baseline width max-height start-y end-x end-y) text-record
807 (if (and strings (eq (second (first (last strings))) text-style))
808 (vector-push-extend character (third (first (last strings))))
809 (setq strings (nconc strings (list (list end-x text-style (make-array 1 :initial-element character :element-type 'character :adjustable t :fill-pointer t))))))
810 (setq baseline (max baseline new-baseline)
811 end-x (+ end-x char-width)
812 max-height (max max-height height)
813 end-y (max end-y (+ start-y max-height))
814 width (+ width char-width)))
815 (tree-recompute-extent text-record))
816
817 (defmethod add-string-output-to-text-record ((text-record text-displayed-output-record)
818 string start end text-style string-width height
819 new-baseline)
820 (if end
821 (setq end (min end (1- (length string))))
822 (setq end (1- (length string))))
823 (let ((length (max 0 (- (1+ end) start))))
824 (cond
825 ((= length 1)
826 (add-character-output-to-text-record text-record (aref string start) text-style string-width height new-baseline))
827 (t
828 (setq string (make-array length :displaced-to string
829 :displaced-index-offset start
830 :element-type (array-element-type string)))
831 (with-slots (strings baseline width max-height start-y end-x end-y) text-record
832 (setq baseline (max baseline new-baseline)
833 strings (nconc strings
834 (list (list end-x text-style
835 (make-array (length string)
836 :initial-contents string
837 :element-type 'character
838 :adjustable t
839 :fill-pointer t))))
840 end-x (+ end-x string-width)
841 max-height (max max-height height)
842 end-y (max end-y (+ start-y max-height))
843 width (+ width string-width)))
844 (tree-recompute-extent text-record)))))
845
846 (defmethod replay-output-record ((record text-displayed-output-record) stream
847 &optional region (x-offset 0) (y-offset 0))
848 (declare (ignore region))
849 (with-slots (strings baseline max-height start-x start-y wrapped
850 x y x1 y1 initial-x1 initial-y1) record
851 (let ((old-medium (sheet-medium stream))
852 (new-medium (make-medium (port stream) stream)))
853 (unwind-protect
854 (progn
855 (setf (sheet-medium stream) new-medium)
856 (setf (medium-sheet new-medium) stream)
857 (setf (medium-transformation new-medium)
858 (make-translation-transformation
859 x-offset
860 y-offset))
861
862 (setf (stream-cursor-position stream) (values start-x start-y))
863 (letf (((slot-value stream 'baseline) baseline))
864 (loop for (x text-style string) in strings
865 do (setf (medium-text-style new-medium) text-style)
866 (setf (stream-cursor-position stream)
867 (values (+ x (- x1 initial-x1)) start-y))
868 (stream-write-line stream string)))
869 ;; clipping region
870 #|restore cursor position? set to (end-x,end-y)?|#
871 #+nil(loop for y = (+ start-y baseline)
872 for (x text-style string) in strings
873 do (setf (medium-text-style new-medium) text-style)
874 (draw-text* (sheet-medium stream) string x y
875 :text-style text-style :clipping-region (untransform-region (medium-transformation new-medium) region)))
876 (if wrapped
877 (draw-rectangle* (sheet-medium stream)
878 (+ wrapped 0) start-y (+ wrapped 4) (+ start-y max-height)
879 :ink +foreground-ink+
880 :filled t)))
881 (setf (sheet-medium stream) old-medium)))))
882
883 (defmethod output-record-start-cursor-position ((record text-displayed-output-record))
884 (with-slots (start-x start-y) record
885 (values start-x start-y)))
886
887 (defmethod output-record-end-cursor-position ((record text-displayed-output-record))
888 (with-slots (end-x end-y) record
889 (values end-x end-y)))
890
891 (defmethod text-displayed-output-record-string ((record text-displayed-output-record))
892 (with-slots (strings) record
893 (loop for result = ""
894 for s in strings
895 do (setq result (concatenate 'string result (third s)))
896 finally (return result))))
897
898
899 ;;; Methods for text output to output recording streams
900 (defmethod stream-text-output-record ((stream standard-output-recording-stream) text-style)
901 (declare (ignore text-style))
902 (let ((record (stream-current-text-output-record stream)))
903 (unless record
904 (setf (stream-current-text-output-record stream)
905 (setq record (make-instance 'text-displayed-output-record)))
906 (with-slots (start-x start-y end-x end-y x1 y1 x2 y2 x y
907 initial-x1 initial-y1) record
908 (multiple-value-bind (cx cy) (stream-cursor-position stream)
909 (setq start-x cx
910 start-y cy
911 end-x start-x
912 end-y start-y
913 x1 (coordinate start-x)
914 x2 (coordinate end-x)
915 y1 (coordinate start-y)
916 y2 (coordinate end-y)
917 initial-x1 x1
918 initial-y1 y1
919 x start-x
920 y start-y))))
921 record))
922
923 (defmethod stream-close-text-output-record ((stream standard-output-recording-stream))
924 (let ((record (stream-current-text-output-record stream)))
925 (when record
926 (setf (stream-current-text-output-record stream) nil)
927 #|record stream-current-cursor-position to (end-x record) - already done|#
928 (stream-add-output-record stream record))))
929
930 (defmethod stream-add-character-output ((stream standard-output-recording-stream)
931 character text-style
932 width height baseline)
933 (add-character-output-to-text-record (stream-text-output-record stream text-style)
934 character text-style width height baseline))
935
936 (defmethod stream-add-string-output ((stream standard-output-recording-stream)
937 string start end text-style
938 width height baseline)
939 (add-string-output-to-text-record (stream-text-output-record stream text-style)
940 string start end text-style
941 width height baseline))
942
943 (defmacro without-local-recording (stream &body body)
944 `(letf (((slot-value ,stream 'local-record-p) nil))
945 ,@body))
946
947 (defmethod stream-write-line :around ((stream standard-output-recording-stream) line)
948 (when (and (stream-recording-p stream)
949 (slot-value stream 'local-record-p))
950 (let* ((medium (sheet-medium stream))
951 (text-style (medium-text-style medium)))
952 (stream-add-string-output stream line 0 nil text-style
953 (stream-string-width stream line
954 :text-style text-style)
955 (text-style-height text-style medium)
956 (text-style-ascent text-style medium))))
957 (when (stream-drawing-p stream)
958 (without-local-recording stream
959 (call-next-method))))
960
961 #+nil
962 (defmethod stream-write-char :around ((stream standard-output-recording-stream) char)
963 (when (and (stream-recording-p stream)
964 (slot-value stream 'local-record-p))
965 (if (or (eql char #\return)
966 (eql char #\newline))
967 (stream-close-text-output-record stream)
968 (let* ((medium (sheet-medium stream))
969 (text-style (medium-text-style medium)))
970 (stream-add-character-output stream char text-style
971 (stream-character-width stream char :text-style text-style)
972 (text-style-height text-style medium)
973 (text-style-ascent text-style medium)))))
974 (without-local-recording stream
975 (call-next-method)))
976
977 #+nil
978 (defmethod stream-write-string :around ((stream standard-output-recording-stream) string
979 &optional (start 0) end)
980 ;; Problem: it is necessary to check for line wrapping. Now the
981 ;; default method for STREAM-WRITE-STRING do char-by-char output,
982 ;; therefore STREAM-WRITE-CHAR can do the right thing.
983 (when (and (stream-recording-p stream)
984 (slot-value stream 'local-record-p))
985 (let* ((medium (sheet-medium stream))
986 (text-style (medium-text-style medium)))
987 (stream-add-string-output stream string start end text-style
988 (stream-string-width stream string
989 :start start :end end
990 :text-style text-style)
991 (text-style-height text-style medium)
992 (text-style-ascent text-style medium))))
993 (without-local-recording stream
994 (call-next-method)))
995
996
997 (defmethod stream-finish-output :after ((stream standard-output-recording-stream))
998 (stream-close-text-output-record stream))
999
1000 (defmethod stream-force-output :after ((stream standard-output-recording-stream))
1001 (stream-close-text-output-record stream))
1002
1003 (defmethod stream-terpri :after ((stream standard-output-recording-stream))
1004 (stream-close-text-output-record stream))
1005
1006 (defmethod* (setf stream-cursor-position) :after (x y (stream standard-output-recording-stream))
1007 (declare (ignore x y))
1008 (stream-close-text-output-record stream))
1009
1010 ;(defmethod stream-set-cursor-position :after ((stream standard-output-recording-stream))
1011 ; (stream-close-text-output-record stream))
1012
1013 (defmethod stream-wrap-line :before ((stream standard-output-recording-stream))
1014 (when (stream-recording-p stream)
1015 (setf (text-record-wrapped (stream-text-output-record stream nil)) ; FIXME!
1016 (stream-text-margin stream))))

  ViewVC Help
Powered by ViewVC 1.1.5