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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5