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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Fri Aug 25 16:10:45 2000 UTC (13 years, 7 months ago) by cvs
Branch: MAIN
Changes since 1.3: +2 -0 lines
Added copyright notice to reflect modifications.
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 (gensym)))
76 `(let ((,old-record-p (stream-recording-p ,stream)))
77 (when ,old-record-p
78 (unwind-protect
79 (progn
80 (setf (stream-recording-p ,stream) nil)
81 (replay-output-record ,record ,stream ,region))
82 (setf (stream-recording-p ,stream) ,old-record-p))))))
83
84 (defmethod replay-output-record ((record output-record) stream
85 &optional region x-offset y-offset)
86 (loop for child in (output-record-children record)
87 do (replay-output-record child stream region x-offset y-offset)))
88
89 (defmethod erase-output-record ((record output-record) stream)
90 (declare (ignore stream))
91 nil)
92
93 (defmethod output-record-hit-detection-rectangle* ((record output-record))
94 (bounding-rectangle* record))
95
96 (defmethod output-record-refined-sensitivity-test ((record output-record) x y)
97 (region-contains-position-p (output-record-hit-detection-rectangle* record) x y))
98
99 (defmethod highlight-output-record ((record output-record) stream state)
100 (multiple-value-bind (x1 y1 x2 y2) (output-record-hit-detection-rectangle* record)
101 (ecase state
102 (:highlight
103 (draw-rectangle* stream x1 y1 x2 y2 :filled nil :ink +foreground-ink+))
104 (:unhighlight
105 (draw-rectangle* stream x1 y1 x2 y2 :filled nil :ink +background-ink+)))))
106
107 (defmethod add-output-record (child (record output-record))
108 (with-slots (children) record
109 (push child children))
110 (with-slots (parent) child
111 (setf parent record)))
112
113 (defmethod delete-output-record (child (record output-record) &optional (errorp t))
114 (with-slots (children) record
115 (if (and errorp
116 (not (member child children)))
117 (error "~S is not a child of ~S" child record))
118 (setq children (delete child children))))
119
120 (defmethod clear-output-record ((record output-record))
121 (with-slots (children x1 y1 x2 y2) record
122 (setq children nil
123 x1 0
124 y1 0
125 x2 0
126 y2 0)))
127
128 (defmethod output-record-count ((record output-record))
129 (length (output-record-children record)))
130
131 (defmethod map-over-output-records-containing-position (function (record output-record) x y
132 &optional (x-offset 0) (y-offset 0))
133 (declare (dynamic-extent function)
134 (ignore x-offset y-offset))
135 (loop for child in (output-record-children record)
136 if (region-contains-position-p (output-record-hit-detection-rectangle* child) x y)
137 do (funcall function child)))
138
139 (defmethod map-over-output-records-overlaping-region (function (record output-record) region
140 &optional (x-offset 0) (y-offset 0))
141 (declare (dynamic-extent function)
142 (ignore x-offset y-offset))
143 (with-bounding-rectangle* (l1 t1 r1 b1) region
144 (loop for child in (output-record-children record)
145 do (with-bounding-rectangle* (l2 t2 r2 b2) child
146 (if (and (<= l2 r1)
147 (>= r2 l1)
148 (<= b2 t1)
149 (>= t2 b1))
150 (funcall function child))))))
151
152 (defmethod recompute-extent-for-new-child ((record output-record) child)
153 (with-bounding-rectangle* (left top right bottom) record
154 (recompute-extent-for-changed-child record child left top right bottom)))
155
156 (defmethod recompute-extent-for-changed-child ((record output-record) child
157 old-min-x old-min-y old-max-x old-max-y)
158 (declare (ignore child old-min-x old-min-y old-max-x old-max-y))
159 (error "I don't understand RECOMPUTE-EXTENT-FOR-CHANGED-CHILD - mikemac"))
160
161 (defmethod tree-recompute-extent ((record output-record))
162 (with-slots (parent children x1 y1 x2 y2) record
163 (if (null children)
164 (setq x1 0
165 y1 0
166 x2 0
167 y2 0)
168 (with-bounding-rectangle* (left top right bottom) (first children)
169 (loop for child in (rest children)
170 do (with-bounding-rectangle* (l1 t1 r1 b1) child
171 (setq left (min left l1 r1)
172 top (min top t1 b1)
173 right (max right l1 r1)
174 bottom (max bottom t1 b1))))
175 (setq x1 left
176 y1 top
177 x2 right
178 y2 bottom)))
179 (if parent
180 (recompute-extent-for-changed-child parent record x1 y1 x2 y2))))
181
182 (defclass standard-sequence-output-record (displayed-output-record)
183 (
184 ))
185
186 (defclass standard-tree-output-record (displayed-output-record)
187 (
188 ))
189
190
191 ;;; Graphics recording classes
192
193 (defclass graphics-displayed-output-record (displayed-output-record)
194 ((ink :initarg :ink)
195 (clip :initarg :clipping-region)
196 (transform :initarg :transformation)
197 (line-style :initarg :line-style)
198 (text-style :initarg :text-style)
199 ))
200
201 (defun graphics-displayed-output-record-p (x)
202 (typep x 'graphics-displayed-output-record))
203
204
205 ;;; stream-output-history-mixin class
206
207 (defclass stream-output-history-mixin ()
208 ((output-history :initform (make-instance 'standard-sequence-output-record)
209 :reader stream-output-history)
210 (recording-p :initform t
211 :accessor stream-recording-p)
212 (drawing-p :initform t
213 :accessor stream-drawing-p)
214 ))
215
216 (defmethod scroll-vertical :around ((stream stream-output-history-mixin) dy)
217 (declare (ignore dy))
218 (with-output-recording-options (stream :record nil)
219 (call-next-method)))
220
221 (defmethod scroll-horizontal :around ((stream stream-output-history-mixin) dx)
222 (declare (ignore dx))
223 (with-output-recording-options (stream :record nil)
224 (call-next-method)))
225
226
227 ;;; standard-tree-output-history class
228
229 (defclass standard-tree-output-history (stream-output-history-mixin)
230 (
231 ))
232
233 (defmethod initialize-instance :after ((history standard-tree-output-history) &rest args)
234 (declare (ignore args))
235 (with-slots (output-history) history
236 (setq output-history (make-instance 'standard-tree-output-record))))
237
238
239 ;;; Output-Recording-Stream class
240
241 (defclass output-recording-stream (standard-tree-output-history)
242 ((current-output-record
243 :accessor stream-current-output-record)
244
245 ))
246
247 (defun output-recording-stream-p (x)
248 (typep x 'output-recording-stream))
249
250 (defmethod initialize-instance :after ((stream output-recording-stream) &rest args)
251 (declare (ignore args))
252 (setf (stream-current-output-record stream) (stream-output-history stream)))
253
254 (defmethod stream-add-output-record ((stream output-recording-stream) record)
255 (add-output-record record (stream-current-output-record stream)))
256
257 (defmethod stream-replay ((stream output-recording-stream) &optional region)
258 (replay (stream-output-history stream) stream region))
259
260 (defclass standard-output-recording-stream (output-recording-stream)
261 (
262 ))
263
264 (defmacro with-output-recording-options ((stream &key (record t) (draw t)) &body body)
265 (let ((old-record (gensym))
266 (old-draw (gensym)))
267 `(with-slots (recording-p drawing-p) ,stream
268 (let ((,old-record recording-p)
269 (,old-draw drawing-p))
270 (unwind-protect
271 (progn
272 (setq recording-p ,record
273 drawing-p ,draw)
274 ,@body)
275 (setq recording-p ,old-record
276 drawing-p ,old-draw))))))
277
278
279 ;;; graphics and text recording classes
280
281 (eval-when (compile load eval)
282
283 (defun compute-class-vars (names)
284 (cons (list 'stream :initarg :stream)
285 (loop for name in names
286 collecting (list name :initarg (intern (symbol-name name) :keyword)))))
287
288 (defun compute-arg-list (names)
289 (loop for name in names
290 nconcing (list (intern (symbol-name name) :keyword) name)))
291 )
292
293 (defun make-merged-medium (sheet ink clip transform line-style text-style)
294 (let ((medium (make-medium (port sheet) sheet)))
295 (setf (medium-ink medium) ink)
296 (setf (medium-clipping-region medium) clip)
297 (setf (medium-transformation medium) transform)
298 (setf (medium-line-style medium) line-style)
299 (setf (medium-text-style medium) text-style)
300 medium))
301
302 (defmacro def-grecording (name (&rest args) &body body)
303 (let ((method-name (intern (format nil "MEDIUM-~A*" name)))
304 (class-name (intern (format nil "~A-OUTPUT-RECORD" name)))
305 (old-medium (gensym))
306 (new-medium (gensym)))
307 `(eval-when (eval load compile)
308 (defclass ,class-name (graphics-displayed-output-record)
309 ,(compute-class-vars args))
310 (defmethod initialize-instance :after ((graphic ,class-name) &rest args)
311 (declare (ignore args))
312 (with-slots (x1 y1 x2 y2
313 stream ink clipping-region transformation
314 line-style text-style
315 ,@args) graphic
316 (multiple-value-bind (lf tp rt bt) (progn ,@body)
317 (setq x1 lf
318 y1 tp
319 x2 rt
320 y2 bt))))
321 (defmethod ,method-name :around ((stream stream-output-history-mixin) ,@args)
322 (with-sheet-medium (medium stream)
323 (let ((record (make-instance ',class-name
324 :stream stream
325 :ink (medium-ink medium)
326 :clipping-region (medium-clipping-region medium)
327 :transformation (medium-transformation medium)
328 :line-style (medium-line-style medium)
329 :text-style (medium-text-style medium)
330 ,@(compute-arg-list args))))
331 (when (stream-recording-p stream)
332 (add-output-record record (stream-output-history stream))
333 )
334 (when (stream-drawing-p stream)
335 (call-next-method)))))
336 (defmethod replay-output-record ((record ,class-name) stream
337 &optional region x-offset y-offset)
338 (declare (ignore region x-offset y-offset))
339 (with-slots (ink clip transform line-style text-style ,@args) record
340 (let ((,old-medium (sheet-medium stream))
341 (,new-medium (make-merged-medium stream ink clip transform line-style text-style)))
342 (unwind-protect
343 (progn
344 (setf (sheet-medium stream) ,new-medium)
345 (setf (medium-sheet ,new-medium) stream)
346 (,method-name ,new-medium ,@args))
347 (setf (sheet-medium stream) ,old-medium))))))))
348
349 (def-grecording draw-point (x y)
350 (values x y x y))
351
352 (def-grecording draw-points (coord-seq)
353 (loop for (x y) on coord-seq by #'cddr
354 minimize x into min-x
355 minimize y into min-y
356 maximize x into max-x
357 maximize y into max-y
358 finally (return (values min-x min-y max-x max-y))))
359
360 (def-grecording draw-line (x1 y1 x2 y2)
361 (values (min x1 x2) (min y1 y2) (max x1 x2) (max y1 y2)))
362
363 (def-grecording draw-lines (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-polygon (coord-seq closed filled)
372 (loop for (x y) on coord-seq by #'cddr
373 minimize x into min-x
374 minimize y into min-y
375 maximize x into max-x
376 maximize y into max-y
377 finally (return (values min-x min-y max-x max-y))))
378
379 (def-grecording draw-rectangle (left top right bottom filled)
380 (values (min left right) (min top bottom) (max left right) (max top bottom)))
381
382 (def-grecording draw-ellipse (center-x center-y
383 radius-1-dx radius-1-dy radius-2-dx radius-2-dy
384 start-angle end-angle filled)
385 (values center-x center-y center-x center-y))
386
387 (def-grecording draw-text (string x y start end
388 align-x align-y toward-x toward-y transform-glyphs)
389 (let* ((width (stream-string-width stream string
390 :start start :end end
391 :text-style text-style))
392 (ascent (text-style-ascent text-style (port (sheet-medium stream))))
393 (descent (text-style-descent text-style (port (sheet-medium stream))))
394 (height (+ ascent descent))
395 left top right bottom)
396 (ecase align-x
397 (:left (setq left x
398 right (+ x width)))
399 (:right (setq left (- x width)
400 right x))
401 (:center (setq left (- x (round width 2))
402 right (+ x (round width 2)))))
403 (ecase align-y
404 (:baseline (setq top (- y height)
405 bottom (+ y descent)))
406 (:top (setq top y
407 bottom (+ y height)))
408 (:bottom (setq top (- y height)
409 bottom y))
410 (:center (setq top (- y (floor height 2))
411 bottom (+ y (ceiling height 2)))))
412 (values left top right bottom)))
413
414
415 ;;; Text recording class
416
417 (defclass text-displayed-output-record (displayed-output-record)
418 ((strings :initform nil)
419 (baseline :initform 0)
420 (max-height :initform 0)
421 (start-x :initarg :start-x
422 :initform 0)
423 (start-y :initarg :start-y
424 :initform 0)
425 (end-x)
426 (end-y)))
427
428 (defmethod initialize-instance :after ((record text-displayed-output-record) &rest args)
429 (declare (ignore args))
430 (with-slots (start-x start-y end-x end-y) record
431 (setq end-x start-x
432 end-y start-y)))
433
434 (defun text-displayed-output-record-p (x)
435 (typep x 'text-displayed-output-record))
436
437
438 (defmethod add-character-output-to-text-record ((text-record text-displayed-output-record)
439 character text-style width height
440 new-baseline)
441 (with-slots (strings baseline max-height end-x) text-record
442 (setq baseline new-baseline
443 strings (nconc strings (list (list end-x text-style (make-string 1 :initial-element character))))
444 end-x (+ end-x width)
445 max-height (max max-height height)
446 )))
447
448 (defmethod add-string-output-to-text-record ((text-record text-displayed-output-record)
449 string start end text-style width height
450 new-baseline)
451 (with-slots (strings baseline max-height end-x) text-record
452 (setq baseline new-baseline
453 strings (nconc strings (list (list end-x text-style (subseq string start end))))
454 end-x (+ end-x width)
455 max-height (max max-height height)
456 )))
457
458 (defmethod replay-output-record ((record text-displayed-output-record) stream
459 &optional region x-offset y-offset)
460 (declare (ignore x-offset y-offset))
461 (with-slots (strings baseline max-height start-x start-y) record
462 (loop for y = start-y
463 for (x text-style string) in strings
464 do (draw-text* stream string x y :text-style text-style :clipping-region region))))
465
466 (defmethod output-record-start-cursor-position ((record text-displayed-output-record))
467 (with-slots (start-x start-y) record
468 (values start-x start-y)))
469
470 (defmethod output-record-end-cursor-position ((record text-displayed-output-record))
471 (with-slots (end-x end-y) record
472 (values end-x end-y)))
473
474 (defmethod text-displayed-output-record-string ((record text-displayed-output-record))
475 (with-slots (strings) record
476 (loop for result = ""
477 for s in strings
478 do (setq result (concatenate 'string result (third s)))
479 finally (return result))))

  ViewVC Help
Powered by ViewVC 1.1.5