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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1.1.1 - (hide annotations) (vendor branch)
Thu Jun 8 22:01:12 2000 UTC (13 years, 10 months ago) by mikemac
Branch: initial
CVS Tags: start
Changes since 1.1: +0 -0 lines
Initial check-in
1 mikemac 1.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