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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.10 - (show annotations)
Sat Jan 20 22:34:39 2001 UTC (13 years, 3 months ago) by cvs
Branch: MAIN
Changes since 1.9: +16 -16 lines
bug fixes by Paul Werkowski
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
7 ;;; This library is free software; you can redistribute it and/or
8 ;;; modify it under the terms of the GNU Library General Public
9 ;;; License as published by the Free Software Foundation; either
10 ;;; version 2 of the License, or (at your option) any later version.
11 ;;;
12 ;;; This library is distributed in the hope that it will be useful,
13 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15 ;;; Library General Public License for more details.
16 ;;;
17 ;;; You should have received a copy of the GNU Library General Public
18 ;;; License along with this library; if not, write to the
19 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 ;;; Boston, MA 02111-1307 USA.
21
22 (in-package :CLIM-INTERNALS)
23
24 (defclass output-record (standard-bounding-rectangle)
25 ((x :initarg :x-position
26 :initform 0)
27 (y :initarg :y-position
28 :initform 0)
29 (parent :initarg :parent
30 :initform nil)
31 (children :initform nil
32 :reader output-record-children)
33 )
34 (:default-initargs :min-x 0 :min-y 0 :max-x 0 :max-y 0))
35
36 (defun output-record-p (x)
37 (typep x 'output-record))
38
39 (defclass displayed-output-record (output-record)
40 (
41 ))
42
43 (defun displayed-output-record-p (x)
44 (typep x 'displayed-output-record))
45
46 (defmethod initialize-instance :after ((record displayed-output-record) &rest args
47 &key size
48 &allow-other-keys)
49 (declare (ignore args size)))
50
51 (defmethod output-record-position ((record displayed-output-record))
52 (with-slots (x y) record
53 (values x y)))
54
55 (defmethod setf*-output-record-position (nx ny (record displayed-output-record))
56 (with-slots (x y) record
57 (setq x nx
58 y ny)))
59
60 (defmethod output-record-start-cursor-position ((record displayed-output-record))
61 (values nil nil))
62
63 (defmethod setf*-output-record-start-cursor-position (x y (record displayed-output-record))
64 (declare (ignore x y))
65 nil)
66
67 (defmethod output-record-end-cursor-position ((record displayed-output-record))
68 (values nil nil))
69
70 (defmethod setf*-output-record-end-cursor-position (x y (record displayed-output-record))
71 (declare (ignore x y))
72 nil)
73
74 (defun replay (record stream &optional region)
75 (let ((old-record-p (stream-recording-p stream))
76 (old-draw-p (stream-drawing-p stream)))
77 (unwind-protect
78 (progn
79 (setf (stream-recording-p stream) nil
80 (stream-drawing-p stream) t)
81 (replay-output-record record stream region))
82 (setf (stream-recording-p stream) old-record-p
83 (stream-drawing-p stream) old-draw-p))))
84
85 (defmethod replay-output-record ((record output-record) stream
86 &optional region x-offset y-offset)
87 (loop for child in (output-record-children record)
88 do (replay-output-record child stream region x-offset y-offset)))
89
90 (defmethod erase-output-record ((record output-record) stream)
91 (declare (ignore stream))
92 nil)
93
94 (defmethod output-record-hit-detection-rectangle* ((record output-record))
95 (bounding-rectangle* record))
96
97 (defmethod output-record-refined-sensitivity-test ((record output-record) x y)
98 (region-contains-position-p (output-record-hit-detection-rectangle* record) x y))
99
100 (defmethod highlight-output-record ((record output-record) stream state)
101 (multiple-value-bind (x1 y1 x2 y2) (output-record-hit-detection-rectangle* record)
102 (ecase state
103 (:highlight
104 (draw-rectangle* stream x1 y1 x2 y2 :filled nil :ink +foreground-ink+))
105 (:unhighlight
106 (draw-rectangle* stream x1 y1 x2 y2 :filled nil :ink +background-ink+)))))
107
108 (defmethod add-output-record (child (record output-record))
109 (with-slots (children) record
110 (push child children))
111 (with-slots (parent) child
112 (setf parent record)))
113
114 (defmethod delete-output-record (child (record output-record) &optional (errorp t))
115 (with-slots (children) record
116 (if (and errorp
117 (not (member child children)))
118 (error "~S is not a child of ~S" child record))
119 (setq children (delete child children))))
120
121 (defmethod clear-output-record ((record output-record))
122 (with-slots (children x1 y1 x2 y2) record
123 (setq children nil
124 x1 0
125 y1 0
126 x2 0
127 y2 0)))
128
129 (defmethod output-record-count ((record output-record))
130 (length (output-record-children record)))
131
132 (defmethod map-over-output-records-containing-position (function (record output-record) x y
133 &optional (x-offset 0) (y-offset 0))
134 (declare (dynamic-extent function)
135 (ignore x-offset y-offset))
136 (loop for child in (output-record-children record)
137 if (region-contains-position-p (output-record-hit-detection-rectangle* child) x y)
138 do (funcall function child)))
139
140 (defmethod map-over-output-records-overlaping-region (function (record output-record) region
141 &optional (x-offset 0) (y-offset 0))
142 (declare (dynamic-extent function)
143 (ignore x-offset y-offset))
144 (with-bounding-rectangle* (l1 t1 r1 b1) region
145 (loop for child in (output-record-children record)
146 do (with-bounding-rectangle* (l2 t2 r2 b2) child
147 (if (and (<= l2 r1)
148 (>= r2 l1)
149 (<= b2 t1)
150 (>= t2 b1))
151 (funcall function child))))))
152
153 (defmethod recompute-extent-for-new-child ((record output-record) child)
154 (with-bounding-rectangle* (left top right bottom) record
155 (recompute-extent-for-changed-child record child left top right bottom)))
156
157 (defmethod recompute-extent-for-changed-child ((record output-record) child
158 old-min-x old-min-y old-max-x old-max-y)
159 (declare (ignore child old-min-x old-min-y old-max-x old-max-y))
160 (tree-recompute-extent record))
161
162 (defmethod tree-recompute-extent ((record output-record))
163 (with-slots (parent children x1 y1 x2 y2) record
164 (if (null children)
165 (setq x1 0
166 y1 0
167 x2 0
168 y2 0)
169 (with-bounding-rectangle* (left top right bottom) (first children)
170 (loop for child in (rest children)
171 do (with-bounding-rectangle* (l1 t1 r1 b1) child
172 (setq left (min left l1 r1)
173 top (min top t1 b1)
174 right (max right l1 r1)
175 bottom (max bottom t1 b1))))
176 (setq x1 left
177 y1 top
178 x2 right
179 y2 bottom)))
180 (if parent
181 (recompute-extent-for-changed-child parent record x1 y1 x2 y2))))
182
183 (defclass standard-sequence-output-record (displayed-output-record)
184 (
185 ))
186
187 (defclass standard-tree-output-record (displayed-output-record)
188 (
189 ))
190
191
192 ;;; Graphics recording classes
193
194 (defclass graphics-displayed-output-record (displayed-output-record)
195 ((ink :initarg :ink)
196 (clip :initarg :clipping-region)
197 (transform :initarg :transformation)
198 (line-style :initarg :line-style)
199 (text-style :initarg :text-style)
200 ))
201
202 (defun graphics-displayed-output-record-p (x)
203 (typep x 'graphics-displayed-output-record))
204
205
206 ;;; stream-output-history-mixin class
207
208 (defclass stream-output-history-mixin ()
209 ((output-history :initform (make-instance 'standard-sequence-output-record)
210 :reader stream-output-history)
211 (recording-p :initform t
212 :accessor stream-recording-p)
213 (drawing-p :initform t
214 :accessor stream-drawing-p)
215 ))
216
217 (defmacro with-output-recording-options ((stream &key (record t) (draw t)) &body body)
218 (let ((old-record (gensym))
219 (old-draw (gensym)))
220 `(with-slots (recording-p drawing-p) ,stream
221 (let ((,old-record recording-p)
222 (,old-draw drawing-p))
223 (unwind-protect
224 (progn
225 (setq recording-p ,record
226 drawing-p ,draw)
227 ,@body)
228 (setq recording-p ,old-record
229 drawing-p ,old-draw))))))
230
231 (defmethod scroll-vertical :around ((stream stream-output-history-mixin) dy)
232 (declare (ignore dy))
233 (with-output-recording-options (stream :record nil)
234 (call-next-method)))
235
236 (defmethod scroll-horizontal :around ((stream stream-output-history-mixin) dx)
237 (declare (ignore dx))
238 (with-output-recording-options (stream :record nil)
239 (call-next-method)))
240
241 (defmethod repaint-sheet ((stream stream-output-history-mixin) region)
242 (replay (stream-output-history stream) stream region))
243
244 (defmethod handle-event ((stream stream-output-history-mixin) (event window-repaint-event))
245 (repaint-sheet stream nil))
246
247 (defmethod handle-event ((stream stream-output-history-mixin) (event pointer-button-press-event))
248 (with-slots (button x y) event
249 (format *debug-io* "button ~D pressed at ~D,~D~%" button x y)))
250
251
252 ;;; standard-tree-output-history class
253
254 (defclass standard-tree-output-history (stream-output-history-mixin)
255 (
256 ))
257
258 (defmethod initialize-instance :after ((history standard-tree-output-history) &rest args)
259 (declare (ignore args))
260 (with-slots (output-history) history
261 (setq output-history (make-instance 'standard-tree-output-record))))
262
263
264 ;;; Output-Recording-Stream class
265
266 (defclass output-recording-stream (standard-tree-output-history)
267 ((current-output-record
268 :accessor stream-current-output-record)
269 (drawing-p :initform t :accessor stream-drawing-p)
270 ))
271
272 (defun output-recording-stream-p (x)
273 (typep x 'output-recording-stream))
274
275 (defmethod initialize-instance :after ((stream output-recording-stream) &rest args)
276 (declare (ignore args))
277 (setf (stream-current-output-record stream) (stream-output-history stream)))
278
279 (defmethod stream-add-output-record ((stream output-recording-stream) record)
280 (add-output-record record (stream-current-output-record stream)))
281
282 (defmethod stream-replay ((stream output-recording-stream) &optional region)
283 (replay (stream-output-history stream) stream region))
284
285 (defclass standard-output-recording-stream (output-recording-stream)
286 (
287 ))
288
289
290 ;;; graphics and text recording classes
291
292 (eval-when (compile load eval)
293
294 (defun compute-class-vars (names)
295 (cons (list 'stream :initarg :stream)
296 (loop for name in names
297 collecting (list name :initarg (intern (symbol-name name) :keyword)))))
298
299 (defun compute-arg-list (names)
300 (loop for name in names
301 nconcing (list (intern (symbol-name name) :keyword) name)))
302 )
303
304 (defun make-merged-medium (sheet ink clip transform line-style text-style)
305 (let ((medium (make-medium (port sheet) sheet)))
306 (setf (medium-ink medium) ink)
307 (setf (medium-clipping-region medium) clip)
308 (setf (medium-transformation medium) transform)
309 (setf (medium-line-style medium) line-style)
310 (setf (medium-text-style medium) text-style)
311 medium))
312
313 (defmacro def-grecording (name (&rest args) &body body)
314 (let ((method-name (intern (format nil "MEDIUM-~A*" name)))
315 (class-name (intern (format nil "~A-OUTPUT-RECORD" name)))
316 (old-medium (gensym))
317 (new-medium (gensym)))
318 `(progn
319 (defclass ,class-name (graphics-displayed-output-record)
320 ,(compute-class-vars args))
321 (defmethod initialize-instance :after ((graphic ,class-name) &rest args)
322 (declare (ignore args))
323 (with-slots (x1 y1 x2 y2
324 stream ink clipping-region transformation
325 line-style text-style
326 ,@args) graphic
327 (multiple-value-bind (lf tp rt bt) (progn ,@body)
328 (setq x1 lf
329 y1 tp
330 x2 rt
331 y2 bt))))
332 (defmethod ,method-name :around ((stream stream-output-history-mixin) ,@args)
333 (with-sheet-medium (medium stream)
334 (when (stream-recording-p stream)
335 (let ((record (make-instance ',class-name
336 :stream stream
337 :ink (medium-ink medium)
338 :clipping-region (medium-clipping-region medium)
339 :transformation (medium-transformation medium)
340 :line-style (medium-line-style medium)
341 :text-style (medium-text-style medium)
342 ,@(compute-arg-list args))))
343 (add-output-record record (stream-output-history stream))
344 ))
345 (when (stream-drawing-p stream)
346 (call-next-method))))
347 (defmethod replay-output-record ((record ,class-name) stream
348 &optional region x-offset y-offset)
349 (declare (ignore region x-offset y-offset))
350 (with-slots (ink clip transform line-style text-style ,@args) record
351 (let ((,old-medium (sheet-medium stream))
352 (,new-medium (make-merged-medium stream ink clip transform line-style text-style)))
353 (unwind-protect
354 (progn
355 (setf (sheet-medium stream) ,new-medium)
356 (setf (medium-sheet ,new-medium) stream)
357 (,method-name ,new-medium ,@args))
358 (setf (sheet-medium stream) ,old-medium))))))))
359
360 (def-grecording draw-point (x y)
361 (values x y x y))
362
363 (def-grecording draw-points (coord-seq)
364 (loop for (x y) on coord-seq by #'cddr
365 minimize x into min-x
366 minimize y into min-y
367 maximize x into max-x
368 maximize y into max-y
369 finally (return (values min-x min-y max-x max-y))))
370
371 (def-grecording draw-line (x1 y1 x2 y2)
372 (values (min x1 x2) (min y1 y2) (max x1 x2) (max y1 y2)))
373
374 (def-grecording draw-lines (coord-seq)
375 (loop for (x y) on coord-seq by #'cddr
376 minimize x into min-x
377 minimize y into min-y
378 maximize x into max-x
379 maximize y into max-y
380 finally (return (values min-x min-y max-x max-y))))
381
382 (def-grecording draw-polygon (coord-seq closed filled)
383 (loop for (x y) on coord-seq by #'cddr
384 minimize x into min-x
385 minimize y into min-y
386 maximize x into max-x
387 maximize y into max-y
388 finally (return (values min-x min-y max-x max-y))))
389
390 (def-grecording draw-rectangle (left top right bottom filled)
391 (values (min left right) (min top bottom) (max left right) (max top bottom)))
392
393 (def-grecording draw-ellipse (center-x center-y
394 radius-1-dx radius-1-dy radius-2-dx radius-2-dy
395 start-angle end-angle filled)
396 (values center-x center-y center-x center-y))
397
398 ;(def-grecording draw-text (string x y start end
399 ; align-x align-y toward-x toward-y transform-glyphs)
400 ; (let* ((width (stream-string-width stream string
401 ; :start start :end end
402 ; :text-style text-style))
403 ; (ascent (text-style-ascent text-style (port (sheet-medium stream))))
404 ; (descent (text-style-descent text-style (port (sheet-medium stream))))
405 ; (height (+ ascent descent))
406 ; left top right bottom)
407 ; (ecase align-x
408 ; (:left (setq left x
409 ; right (+ x width)))
410 ; (:right (setq left (- x width)
411 ; right x))
412 ; (:center (setq left (- x (round width 2))
413 ; right (+ x (round width 2)))))
414 ; (ecase align-y
415 ; (:baseline (setq top (- y height)
416 ; bottom (+ y descent)))
417 ; (:top (setq top y
418 ; bottom (+ y height)))
419 ; (:bottom (setq top (- y height)
420 ; bottom y))
421 ; (:center (setq top (- y (floor height 2))
422 ; bottom (+ y (ceiling height 2)))))
423 ; (values left top right bottom)))
424
425
426 ;;; Text recording class
427
428 (defclass text-displayed-output-record (displayed-output-record)
429 ((strings :initform nil)
430 (baseline :initform 0)
431 (max-height :initform 0)
432 (start-x :initarg :start-x)
433 (start-y :initarg :start-y)
434 (end-x)
435 (end-y)
436 (wrapped :initform nil
437 :accessor text-record-wrapped)))
438
439 (defun text-displayed-output-record-p (x)
440 (typep x 'text-displayed-output-record))
441
442 (defmethod print-object ((self text-displayed-output-record) stream)
443 (print-unreadable-object (self stream :type t :identity t)
444 (if (slot-boundp self 'start-x)
445 (with-slots (start-x start-y strings) self
446 (format stream "~D,~D ~S" start-x start-y (mapcar #'third strings)))
447 (format stream "empty"))))
448
449 (defmethod tree-recompute-extent ((text-record text-displayed-output-record))
450 (with-slots (parent start-x start-y end-x end-y x1 y1 x2 y2) text-record
451 (setq x1 start-x
452 x2 end-x
453 y1 start-y
454 y2 end-y)
455 (recompute-extent-for-changed-child parent text-record start-x start-y end-x end-y)))
456
457 (defmethod add-character-output-to-text-record ((text-record text-displayed-output-record)
458 character text-style width height
459 new-baseline)
460 (with-slots (strings baseline max-height start-y end-x end-y) text-record
461 (if (and strings (eq (second (first (last strings))) text-style))
462 (vector-push-extend character (third (first (last strings))))
463 (setq strings (nconc strings (list (list end-x text-style (make-array 1 :initial-element character :element-type 'character :adjustable t :fill-pointer t))))))
464 (setq baseline (max baseline new-baseline)
465 end-x (+ end-x width)
466 max-height (max max-height height)
467 end-y (max end-y (+ start-y max-height))
468 )
469 )
470 (tree-recompute-extent text-record))
471
472 (defmethod add-string-output-to-text-record ((text-record text-displayed-output-record)
473 string start end text-style width height
474 new-baseline)
475 (setq string (subseq string start end))
476 (with-slots (strings baseline max-height end-x) text-record
477 (setq baseline (max baseline new-baseline)
478 strings (nconc strings (list (list end-x text-style (make-array (length string) :initial-contents string :element-type 'character :adjustable t :fill-pointer t))))
479 end-x (+ end-x width)
480 max-height (max max-height height)
481 )))
482
483 (defmethod replay-output-record ((record text-displayed-output-record) stream
484 &optional region x-offset y-offset)
485 (declare (ignore x-offset y-offset))
486 (with-slots (strings baseline max-height start-x start-y wrapped) record
487 (let ((old-medium (sheet-medium stream))
488 (new-medium (make-medium (port stream) stream)))
489 (unwind-protect
490 (progn
491 (setf (sheet-medium stream) new-medium)
492 (setf (medium-sheet new-medium) stream)
493 (loop for y = (+ start-y baseline)
494 for (x text-style string) in strings
495 do (setf (medium-text-style new-medium) text-style)
496 (draw-text* stream string x y
497 :text-style text-style :clipping-region region))
498 (if wrapped
499 (draw-rectangle* (sheet-medium stream)
500 (+ wrapped 0) start-y (+ wrapped 4) (+ start-y max-height)
501 :ink +foreground-ink+
502 :filled t)))
503 (setf (sheet-medium stream) old-medium)))))
504
505 (defmethod output-record-start-cursor-position ((record text-displayed-output-record))
506 (with-slots (start-x start-y) record
507 (values start-x start-y)))
508
509 (defmethod output-record-end-cursor-position ((record text-displayed-output-record))
510 (with-slots (end-x end-y) record
511 (values end-x end-y)))
512
513 (defmethod text-displayed-output-record-string ((record text-displayed-output-record))
514 (with-slots (strings) record
515 (loop for result = ""
516 for s in strings
517 do (setq result (concatenate 'string result (third s)))
518 finally (return result))))
519
520
521
522 (defmethod get-text-record ((stream output-recording-stream))
523 (let ((trec (stream-current-output-record stream)))
524 (unless (text-displayed-output-record-p trec)
525 (setq trec (make-instance 'text-displayed-output-record))
526 (add-output-record trec (stream-output-history stream))
527 (setf (stream-current-output-record stream) trec)
528 (with-slots (start-x start-y end-x end-y x1 y1 x2 y2) trec
529 (multiple-value-bind (cx cy) (stream-cursor-position stream)
530 (setq start-x cx
531 start-y (+ cy (stream-vertical-spacing stream))
532 end-x start-x
533 end-y start-y
534 x1 start-x
535 x2 end-x
536 y1 start-y
537 y2 end-y))))
538 trec))
539
540 (defmethod stream-write-char :around ((stream output-recording-stream) char)
541 (when (stream-recording-p stream)
542 (get-text-record stream))
543 (call-next-method)
544 (when (stream-recording-p stream)
545 (cond
546 ((not (or (eql char #\return)
547 (eql char #\newline)))
548 (let* ((medium (sheet-medium stream))
549 (text-style (medium-text-style medium))
550 (trec (get-text-record stream))
551 (port (port stream)))
552 (add-character-output-to-text-record
553 trec char text-style
554 (stream-character-width stream char :text-style text-style)
555 (text-style-height text-style port)
556 (text-style-ascent text-style port))))
557 (t
558 (let ((trec (make-instance 'text-displayed-output-record)))
559 (add-output-record trec (stream-output-history stream))
560 (setf (stream-current-output-record stream) trec)
561 (with-slots (start-x start-y end-x end-y x1 y1 x2 y2) trec
562 (multiple-value-bind (cx cy) (stream-cursor-position stream)
563 (setq start-x cx
564 start-y (+ cy (stream-vertical-spacing stream))
565 end-x start-x
566 end-y start-y
567 x1 start-x
568 x2 end-x
569 y1 start-y
570 y2 end-y))))))))
571
572 (defmethod stream-wrap-line :before ((stream output-recording-stream))
573 (when (stream-recording-p stream)
574 (setf (text-record-wrapped (get-text-record stream)) (stream-text-margin stream))))

  ViewVC Help
Powered by ViewVC 1.1.5