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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.35 - (show annotations)
Fri Apr 19 22:27:09 2002 UTC (12 years ago) by moore
Branch: MAIN
Changes since 1.34: +41 -13 lines
Make a global choice, based on multiprocessing or not, whether events
should be handled immediately or queued up to be serviced by another
process.  The choice is implemented by the classes
clim-sheet-input-mixin and clim-repainting-mixin, from which all panes
inherit.  These classes' superclasses are conditionalized on whether or
not the implementation is capable of multiprocessing.

When multiprocessing there is a single event queue per frame.  This is
implemented by queue-event on pane classes.

The event loop is implemented in stream-input-wait.  In single
processing mode, stream-input-wait calls process-next-event and
handles events immediately.  When multiprocessing, stream-input-wait
reads events from the frame event queue and handles them.  The
function clim-extensions:simple-event-loop is supplied for
applications which do not loop reading from a stream; various examples
have been changed to use it.

In stream-read-gesture/stream-input-wait the input-wait-test function
is not expected to block anymore; nor is the input-wait-handler
expected to dispatch events.  input-wait-handler is responsible for
consuming events that should not be seen by anyone
else. input-context-wait-test and highlight-applicable-presentation
have been rewritten to reflect this.

The adjustable-array buffer for extended-input-streams has been added
back in.  A typo in %event-matches-gesture has been fixed.

Default methods for map-over-output-records-containing-position and
map-over-output-records-overlapping-region have been added.

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

  ViewVC Help
Powered by ViewVC 1.1.5