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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (hide annotations)
Thu Nov 2 00:12:13 2000 UTC (13 years, 5 months ago) by cvs
Branch: MAIN
Changes since 1.4: +74 -39 lines
reworking output history - doesn't handle CR correct yet
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     (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 cvs 1.3 (with-slots (children x1 y1 x2 y2) record
122 mikemac 1.1 (setq children nil
123 cvs 1.3 x1 0
124     y1 0
125     x2 0
126     y2 0)))
127 mikemac 1.1
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 cvs 1.3 (with-slots (parent children x1 y1 x2 y2) record
163 mikemac 1.1 (if (null children)
164 cvs 1.3 (setq x1 0
165     y1 0
166     x2 0
167     y2 0)
168 mikemac 1.1 (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 cvs 1.3 (setq x1 left
176     y1 top
177     x2 right
178     y2 bottom)))
179 mikemac 1.1 (if parent
180 cvs 1.3 (recompute-extent-for-changed-child parent record x1 y1 x2 y2))))
181 mikemac 1.1
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 cvs 1.5 (drawing-p :initform t :accessor stream-drawing-p)
245 mikemac 1.1 ))
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 cvs 1.2 collecting (list name :initarg (intern (symbol-name name) :keyword)))))
287 mikemac 1.1
288     (defun compute-arg-list (names)
289     (loop for name in names
290 cvs 1.2 nconcing (list (intern (symbol-name name) :keyword) name)))
291 mikemac 1.1 )
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 cvs 1.3 (with-slots (x1 y1 x2 y2
313 mikemac 1.1 stream ink clipping-region transformation
314     line-style text-style
315     ,@args) graphic
316     (multiple-value-bind (lf tp rt bt) (progn ,@body)
317 cvs 1.3 (setq x1 lf
318     y1 tp
319     x2 rt
320     y2 bt))))
321 mikemac 1.1 (defmethod ,method-name :around ((stream stream-output-history-mixin) ,@args)
322     (with-sheet-medium (medium stream)
323 cvs 1.5 (when (stream-recording-p stream)
324     (let ((record (make-instance ',class-name
325     :stream stream
326     :ink (medium-ink medium)
327     :clipping-region (medium-clipping-region medium)
328     :transformation (medium-transformation medium)
329     :line-style (medium-line-style medium)
330     :text-style (medium-text-style medium)
331     ,@(compute-arg-list args))))
332 mikemac 1.1 (add-output-record record (stream-output-history stream))
333 cvs 1.5 ))
334     (when (stream-drawing-p stream)
335     (call-next-method))))
336 mikemac 1.1 (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 cvs 1.5 ;(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 mikemac 1.1
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))))
480 cvs 1.5
481    
482    
483     (defmethod get-text-record ((stream output-recording-stream))
484     (let ((trec (stream-current-output-record stream)))
485     (unless (text-displayed-output-record-p trec)
486     (setq trec (make-instance 'text-displayed-output-record))
487     (add-output-record trec (stream-current-output-record stream))
488     (setf (stream-current-output-record stream) trec))
489     trec))
490    
491     (defmethod stream-write-char :around ((stream output-recording-stream) char)
492     (when (stream-recording-p stream)
493     (let ((medium (sheet-medium stream))
494     (trec (get-text-record stream)))
495     (multiple-value-bind (width height ignore1 ignore2 baseline)
496     (text-size medium (string char))
497     (declare (ignore ignore1 ignore2))
498     (add-character-output-to-text-record trec char
499     (medium-text-style medium)
500     width height baseline))))
501     (call-next-method))
502    
503     (defmethod stream-write-string :around ((stream output-recording-stream) string
504     &optional (start 0) end)
505     (when (stream-recording-p stream)
506     (let ((medium (sheet-medium stream))
507     (trec (get-text-record stream)))
508     (multiple-value-bind (width height ignore1 ignore2 baseline)
509     (text-size medium string)
510     (declare (ignore ignore1 ignore2))
511     (add-string-output-to-text-record trec string start end
512     (medium-text-style medium)
513     width height baseline))))
514     (call-next-method))

  ViewVC Help
Powered by ViewVC 1.1.5