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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.10 - (hide 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 mikemac 1.1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2    
3     ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com)
4 cvs 1.4 ;;; (c) copyright 2000 by
5     ;;; Robert Strandh (strandh@labri.u-bordeaux.fr)
6 mikemac 1.1
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 cvs 1.7 (let ((old-record-p (stream-recording-p stream))
76     (old-draw-p (stream-drawing-p stream)))
77 cvs 1.8 (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 mikemac 1.1
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 cvs 1.3 (with-slots (children x1 y1 x2 y2) record
123 mikemac 1.1 (setq children nil
124 cvs 1.3 x1 0
125     y1 0
126     x2 0
127     y2 0)))
128 mikemac 1.1
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 cvs 1.9 (tree-recompute-extent record))
161 mikemac 1.1
162     (defmethod tree-recompute-extent ((record output-record))
163 cvs 1.3 (with-slots (parent children x1 y1 x2 y2) record
164 mikemac 1.1 (if (null children)
165 cvs 1.3 (setq x1 0
166     y1 0
167     x2 0
168     y2 0)
169 mikemac 1.1 (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 cvs 1.3 (setq x1 left
177     y1 top
178     x2 right
179     y2 bottom)))
180 mikemac 1.1 (if parent
181 cvs 1.3 (recompute-extent-for-changed-child parent record x1 y1 x2 y2))))
182 mikemac 1.1
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 cvs 1.10 (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 mikemac 1.1 (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 cvs 1.7 (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 mikemac 1.1
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 cvs 1.5 (drawing-p :initform t :accessor stream-drawing-p)
270 mikemac 1.1 ))
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 cvs 1.2 collecting (list name :initarg (intern (symbol-name name) :keyword)))))
298 mikemac 1.1
299     (defun compute-arg-list (names)
300     (loop for name in names
301 cvs 1.2 nconcing (list (intern (symbol-name name) :keyword) name)))
302 mikemac 1.1 )
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 cvs 1.10 `(progn
319 mikemac 1.1 (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 cvs 1.3 (with-slots (x1 y1 x2 y2
324 mikemac 1.1 stream ink clipping-region transformation
325     line-style text-style
326     ,@args) graphic
327     (multiple-value-bind (lf tp rt bt) (progn ,@body)
328 cvs 1.3 (setq x1 lf
329     y1 tp
330     x2 rt
331     y2 bt))))
332 mikemac 1.1 (defmethod ,method-name :around ((stream stream-output-history-mixin) ,@args)
333     (with-sheet-medium (medium stream)
334 cvs 1.5 (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 mikemac 1.1 (add-output-record record (stream-output-history stream))
344 cvs 1.5 ))
345     (when (stream-drawing-p stream)
346     (call-next-method))))
347 mikemac 1.1 (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 cvs 1.5 ;(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 mikemac 1.1
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 cvs 1.6 (start-x :initarg :start-x)
433     (start-y :initarg :start-y)
434 mikemac 1.1 (end-x)
435 cvs 1.8 (end-y)
436     (wrapped :initform nil
437     :accessor text-record-wrapped)))
438 mikemac 1.1
439     (defun text-displayed-output-record-p (x)
440     (typep x 'text-displayed-output-record))
441    
442 cvs 1.8 (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 mikemac 1.1
449 cvs 1.9 (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 mikemac 1.1 (defmethod add-character-output-to-text-record ((text-record text-displayed-output-record)
458     character text-style width height
459     new-baseline)
460 cvs 1.9 (with-slots (strings baseline max-height start-y end-x end-y) text-record
461 cvs 1.7 (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 mikemac 1.1 end-x (+ end-x width)
466     max-height (max max-height height)
467 cvs 1.9 end-y (max end-y (+ start-y max-height))
468 cvs 1.6 )
469 cvs 1.9 )
470     (tree-recompute-extent text-record))
471 mikemac 1.1
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 cvs 1.7 (setq string (subseq string start end))
476 mikemac 1.1 (with-slots (strings baseline max-height end-x) text-record
477 cvs 1.7 (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 mikemac 1.1 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 cvs 1.8 (with-slots (strings baseline max-height start-x start-y wrapped) record
487 cvs 1.7 (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 cvs 1.8 :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 cvs 1.7 (setf (sheet-medium stream) old-medium)))))
504 mikemac 1.1
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 cvs 1.5
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 cvs 1.6 (add-output-record trec (stream-output-history stream))
527 cvs 1.8 (setf (stream-current-output-record stream) trec)
528 cvs 1.9 (with-slots (start-x start-y end-x end-y x1 y1 x2 y2) trec
529 cvs 1.8 (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 cvs 1.9 end-y start-y
534     x1 start-x
535     x2 end-x
536     y1 start-y
537     y2 end-y))))
538 cvs 1.5 trec))
539    
540     (defmethod stream-write-char :around ((stream output-recording-stream) char)
541     (when (stream-recording-p stream)
542 cvs 1.8 (get-text-record stream))
543     (call-next-method)
544     (when (stream-recording-p stream)
545 cvs 1.6 (cond
546 cvs 1.8 ((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 cvs 1.6 (let ((trec (make-instance 'text-displayed-output-record)))
559     (add-output-record trec (stream-output-history stream))
560 cvs 1.8 (setf (stream-current-output-record stream) trec)
561 cvs 1.9 (with-slots (start-x start-y end-x end-y x1 y1 x2 y2) trec
562 cvs 1.8 (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 cvs 1.9 end-y start-y
567     x1 start-x
568     x2 end-x
569     y1 start-y
570     y2 end-y))))))))
571 cvs 1.5
572 cvs 1.8 (defmethod stream-wrap-line :before ((stream output-recording-stream))
573 cvs 1.5 (when (stream-recording-p stream)
574 cvs 1.10 (setf (text-record-wrapped (get-text-record stream)) (stream-text-margin stream))))

  ViewVC Help
Powered by ViewVC 1.1.5