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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.25 - (hide annotations)
Wed Aug 1 12:52:01 2001 UTC (12 years, 8 months ago) by rouanet
Branch: MAIN
Changes since 1.24: +0 -41 lines
Moved the LETF macro from recording.lisp to utils.lisp
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 rouanet 1.11 ;;; (c) copyright 2001 by
7     ;;; Arnaud Rouanet (rouanet@emi.u-bordeaux.fr)
8     ;;; Lionel Salabartan (salabart@emi.u-bordeaux.fr)
9 adejneka 1.20 ;;; Alexey Dejneka (adejneka@comail.ru)
10 mikemac 1.1
11     ;;; This library is free software; you can redistribute it and/or
12     ;;; modify it under the terms of the GNU Library General Public
13     ;;; License as published by the Free Software Foundation; either
14     ;;; version 2 of the License, or (at your option) any later version.
15     ;;;
16     ;;; This library is distributed in the hope that it will be useful,
17     ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18     ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
19     ;;; Library General Public License for more details.
20     ;;;
21     ;;; You should have received a copy of the GNU Library General Public
22     ;;; License along with this library; if not, write to the
23     ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24     ;;; Boston, MA 02111-1307 USA.
25    
26 adejneka 1.21 ;;; TODO:
27     ;;; - Scrolling does not work correctly. Region is given in "window" coordinates,
28     ;;; without bounding-rectangle-position transformation.
29     ;;; - Redo setf*-output-record-position, extent recomputation for
30     ;;; compound records
31     ;;; - How to deal with mixing of positioning/modifying?
32 adejneka 1.22 ;;; - When DRAWING-P is NIL, should stream cursor move?
33     ;;; - OUTPUT-RECORD is a protocol class, it should not have any slots/methods.
34    
35 mikemac 1.1 (in-package :CLIM-INTERNALS)
36    
37 rouanet 1.11 (defclass output-record-mixin ()
38 mikemac 1.1 ((x :initarg :x-position
39 adejneka 1.22 :initform 0
40     :type rational)
41 mikemac 1.1 (y :initarg :y-position
42 adejneka 1.22 :initform 0
43     :type rational)
44 mikemac 1.1 (parent :initarg :parent
45 rouanet 1.11 :initform nil
46     :reader output-record-parent)))
47    
48 rouanet 1.13 (defmethod initialize-instance :after ((record output-record-mixin) &rest args)
49     (declare (ignore args))
50 rouanet 1.11 (with-slots (x1 y1 x2 y2) record
51     (setq x1 0
52     y1 0
53     x2 0
54     y2 0)))
55    
56     (defclass output-record (standard-bounding-rectangle output-record-mixin)
57     ((children :initform nil
58     :reader output-record-children))
59 mikemac 1.1 (:default-initargs :min-x 0 :min-y 0 :max-x 0 :max-y 0))
60    
61     (defun output-record-p (x)
62     (typep x 'output-record))
63    
64 rouanet 1.11 (defclass displayed-output-record (standard-bounding-rectangle output-record-mixin)
65 rouanet 1.18 ((ink :initarg :ink :reader displayed-output-record-ink)
66     (initial-x1 :initarg :initial-x1)
67     (initial-y1 :initarg :initial-y1)))
68 mikemac 1.1
69     (defun displayed-output-record-p (x)
70     (typep x 'displayed-output-record))
71    
72 adejneka 1.21 ; 16.2.1. The Basic Output Record Protocol
73 adejneka 1.22 (declaim (ftype (function (output-record) (values rational rational))
74     output-record-position))
75     (defgeneric output-record-position (record)
76     (:documentation
77     "Returns the x and y position of RECORD. The position is the
78     position of the upper-left corner of its bounding rectangle. The
79     position is relative to the stream, where (0,0) is (initially) the
80     upper-left corner of the stream."))
81    
82 rouanet 1.23 (defgeneric* (setf output-record-position) (x y record))
83 adejneka 1.22
84     (declaim (ftype (function (output-record) (values integer integer))
85     output-record-start-cursor-position))
86     (defgeneric output-record-start-cursor-position (record)
87     (:documentation
88     "Returns the x and y starting cursor position of RECORD. The
89     positions are relative to the stream, where (0,0) is (initially) the
90     upper-left corner of the stream."))
91    
92 rouanet 1.23 (defgeneric* (setf output-record-start-cursor-position) (x y record))
93 adejneka 1.22
94     (declaim (ftype (function (output-record) (values integer integer))
95     output-record-end-cursor-position))
96     (defgeneric output-record-end-cursor-position (record)
97     (:documentation
98     "Returns the x and y ending cursor position of RECORD. The
99     positions are relative to the stream, where (0,0) is (initially) the
100     upper-left corner of the stream."))
101    
102 rouanet 1.23 (defgeneric* (setf output-record-end-cursor-position) (x y record))
103 adejneka 1.22
104     (defgeneric output-record-parent (record)
105     (:documentation
106     "Returns the output record that is the parent of RECORD, or nil if
107     RECORD has no parent."))
108    
109 adejneka 1.21 (defgeneric replay-output-record (record stream
110 adejneka 1.22 &optional region x-offset y-offset)
111     (:documentation "Displays the output captured by RECORD on the
112     STREAM, exactly as it was originally captured. The current user
113     transformation, line style, text style, ink and clipping region of
114     STREAM are all ignored. Instead, these are gotten from the output
115     record.
116    
117     Only those records that overlap REGION are displayed."))
118    
119 adejneka 1.21 (defgeneric output-record-hit-detection-rectangle* (record))
120 adejneka 1.22
121 adejneka 1.21 (defgeneric output-record-refined-position-test (record x y))
122 adejneka 1.22
123 adejneka 1.21 (defgeneric highlight-output-record (record stream state))
124 adejneka 1.22
125 adejneka 1.21 (defgeneric displayed-output-record-ink (displayed-output-record))
126    
127     ; 16.2.2. Output Record "Database" Protocol
128 adejneka 1.22
129 adejneka 1.21 (defgeneric output-record-children (record))
130 adejneka 1.22
131 adejneka 1.21 (defgeneric add-output-record (child record))
132 adejneka 1.22
133 adejneka 1.21 (defgeneric delete-output-record (child record &optional (errorp t)))
134 adejneka 1.22
135 adejneka 1.21 (defgeneric clear-output-record (record))
136 adejneka 1.22
137 adejneka 1.21 (defgeneric output-record-count (record))
138 adejneka 1.22
139 adejneka 1.21 (defgeneric map-over-output-records-containing-position
140     (function record x y &optional x-offset y-offset &rest function-args))
141 adejneka 1.22
142 adejneka 1.21 (defgeneric map-over-output-records-overlapping-region
143     (function record region &optional x-offset y-offset &rest function-args))
144    
145     ; 16.2.3. Output Record Change Notification Protocol
146 adejneka 1.22
147 adejneka 1.21 (defgeneric recompute-extent-for-new-child (record child))
148 adejneka 1.22
149 adejneka 1.21 (defgeneric recompute-extent-for-changed-child
150     (record child old-min-x old-min-y old-max-x old-max-y))
151 adejneka 1.22
152 adejneka 1.21 (defgeneric tree-recompute-extent (record))
153    
154     ;;; Methods
155 adejneka 1.22
156 rouanet 1.11 (defmethod initialize-instance :after ((record output-record) &rest args
157 mikemac 1.1 &key size
158     &allow-other-keys)
159     (declare (ignore args size)))
160    
161 rouanet 1.11 (defmethod output-record-position ((record output-record-mixin))
162 mikemac 1.1 (with-slots (x y) record
163     (values x y)))
164    
165 rouanet 1.23 (defmethod* (setf output-record-position) (nx ny (record output-record-mixin))
166 rouanet 1.18 (with-slots (x y x1 y1 x2 y2) record
167     (let ((dx (- nx x))
168     (dy (- ny y)))
169     (incf x1 dx) (incf y1 dy)
170     (incf x2 dx) (incf y2 dy))
171     (setq x nx
172     y ny)))
173 mikemac 1.1
174 rouanet 1.23 (defmethod* (setf output-record-position) :before (nx ny (record output-record))
175 rouanet 1.11 (multiple-value-bind (old-x old-y) (output-record-position record)
176     (loop with dx = (- nx old-x)
177     and dy = (- ny old-y)
178     for child in (output-record-children record)
179     do (multiple-value-bind (x y) (output-record-position child)
180 rouanet 1.23 (setf (output-record-position child) (values (+ x dx) (+ y dy)))))))
181 rouanet 1.11
182 rouanet 1.23 (defmethod* (setf output-record-position) :around (nx ny (record output-record-mixin))
183 rouanet 1.11 (declare (ignore nx ny))
184     (with-bounding-rectangle* (min-x min-y max-x max-y) record
185     (call-next-method)
186 adejneka 1.16 (let ((parent (output-record-parent record)))
187     (when parent
188     (recompute-extent-for-changed-child parent record
189     min-x min-y max-x max-y)))))
190 rouanet 1.11
191 mikemac 1.1 (defmethod output-record-start-cursor-position ((record displayed-output-record))
192     (values nil nil))
193    
194 rouanet 1.23 (defmethod* (setf output-record-start-cursor-position) (x y (record displayed-output-record))
195 mikemac 1.1 (declare (ignore x y))
196     nil)
197    
198     (defmethod output-record-end-cursor-position ((record displayed-output-record))
199     (values nil nil))
200    
201 rouanet 1.23 (defmethod* (setf output-record-end-cursor-position) (x y (record displayed-output-record))
202 mikemac 1.1 (declare (ignore x y))
203     nil)
204    
205 adejneka 1.24 (defun replay (record stream &optional region)
206 adejneka 1.21 (stream-close-text-output-record stream)
207 rouanet 1.11 (when (stream-drawing-p stream)
208 adejneka 1.22 (with-cursor-off stream
209     (multiple-value-bind (cx cy) (stream-cursor-position stream)
210     (unwind-protect
211     (letf (((stream-recording-p stream) nil))
212     (replay-output-record record stream region))
213 rouanet 1.23 (setf (stream-cursor-position stream) (values cx cy)))))))
214 mikemac 1.1
215     (defmethod replay-output-record ((record output-record) stream
216 rouanet 1.18 &optional region (x-offset 0) (y-offset 0))
217 rouanet 1.11 (when (null region)
218     (setq region +everywhere+))
219     (map-over-output-records-overlaping-region
220     #'replay-output-record record region x-offset y-offset
221     stream region x-offset y-offset))
222 mikemac 1.1
223 adejneka 1.21 (defmethod erase-output-record ((record output-record) stream &optional (errorp t))
224 mikemac 1.1 (declare (ignore stream))
225     nil)
226    
227 rouanet 1.11 (defmethod output-record-hit-detection-rectangle* ((record output-record-mixin))
228 mikemac 1.1 (bounding-rectangle* record))
229    
230 rouanet 1.11 (defmethod output-record-refined-sensitivity-test ((record output-record-mixin) x y)
231 rouanet 1.13 (declare (ignore x y))
232     t)
233 mikemac 1.1
234 rouanet 1.11 (defmethod highlight-output-record ((record output-record-mixin) stream state)
235 mikemac 1.1 (multiple-value-bind (x1 y1 x2 y2) (output-record-hit-detection-rectangle* record)
236     (ecase state
237     (:highlight
238 rouanet 1.11 (draw-rectangle* (sheet-medium stream) x1 y1 x2 y2 :filled nil :ink +foreground-ink+))
239 mikemac 1.1 (:unhighlight
240 rouanet 1.11 (draw-rectangle* (sheet-medium stream) x1 y1 x2 y2 :filled nil :ink +background-ink+)))))
241    
242     (defclass standard-sequence-output-record (output-record)
243     (
244     ))
245    
246     (defclass standard-tree-output-record (output-record)
247     (
248     ))
249    
250 rouanet 1.23 (defmethod* (setf output-record-position) (nx ny (record standard-sequence-output-record))
251 adejneka 1.21 (with-slots (x y) record
252 rouanet 1.23 (setq x nx
253     y ny)))
254 adejneka 1.21
255 rouanet 1.11 (defmethod output-record-children ((output-record output-record))
256     (with-slots (children) output-record
257     (reverse children)))
258 mikemac 1.1
259     (defmethod add-output-record (child (record output-record))
260     (with-slots (children) record
261     (push child children))
262     (with-slots (parent) child
263     (setf parent record)))
264    
265 rouanet 1.11 (defmethod add-output-record :before (child (record output-record))
266     (when (null (output-record-children record))
267     (with-bounding-rectangle* (min-x min-y max-x max-y) child
268     (with-slots (x1 y1 x2 y2) record
269     (setq x1 min-x
270     y1 min-y
271     x2 max-x
272     y2 max-y)))))
273    
274     (defmethod add-output-record :after (child (record output-record))
275     (recompute-extent-for-new-child record child))
276    
277 mikemac 1.1 (defmethod delete-output-record (child (record output-record) &optional (errorp t))
278     (with-slots (children) record
279     (if (and errorp
280     (not (member child children)))
281     (error "~S is not a child of ~S" child record))
282     (setq children (delete child children))))
283    
284 rouanet 1.11 (defmethod delete-output-record :after (child (record output-record) &optional (errorp t))
285     (declare (ignore errorp))
286     (with-bounding-rectangle* (x1 y1 x2 y2) child
287     (recompute-extent-for-changed-child record child x1 y1 x2 y2)))
288    
289 mikemac 1.1 (defmethod clear-output-record ((record output-record))
290 cvs 1.3 (with-slots (children x1 y1 x2 y2) record
291 mikemac 1.1 (setq children nil
292 adejneka 1.21 x1 (coordinate 0)
293     y1 (coordinate 0)
294     x2 (coordinate 0)
295     y2 (coordinate 0))))
296 mikemac 1.1
297     (defmethod output-record-count ((record output-record))
298     (length (output-record-children record)))
299    
300     (defmethod map-over-output-records-containing-position (function (record output-record) x y
301 rouanet 1.11 &optional (x-offset 0) (y-offset 0)
302     &rest function-args)
303 mikemac 1.1 (declare (dynamic-extent function)
304     (ignore x-offset y-offset))
305     (loop for child in (output-record-children record)
306 rouanet 1.13 when (and (region-contains-position-p
307     (multiple-value-call #'make-bounding-rectangle
308     (output-record-hit-detection-rectangle* child))
309     x y)
310     (output-record-refined-sensitivity-test child x y))
311     do (apply function child function-args)))
312 mikemac 1.1
313     (defmethod map-over-output-records-overlaping-region (function (record output-record) region
314 rouanet 1.11 &optional (x-offset 0) (y-offset 0)
315     &rest function-args)
316 mikemac 1.1 (declare (dynamic-extent function)
317     (ignore x-offset y-offset))
318 rouanet 1.11 (loop for child in (output-record-children record)
319     do (when (region-intersects-region-p region child)
320     (apply function child function-args))))
321 mikemac 1.1
322     (defmethod recompute-extent-for-new-child ((record output-record) child)
323 rouanet 1.11 (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2) record
324     (with-slots (parent x1 y1 x2 y2) record
325     (with-bounding-rectangle* (x1-child y1-child x2-child y2-child) child
326     (setq x1 (min x1 x1-child)
327     y1 (min y1 y1-child)
328     x2 (max x2 x2-child)
329     y2 (max y2 y2-child)))
330     (when parent
331     (recompute-extent-for-changed-child parent record old-x1 old-y1 old-x2 old-y2)))))
332 mikemac 1.1
333 rouanet 1.11 (defmethod recompute-extent-for-changed-child :around ((record output-record) child
334     old-min-x old-min-y old-max-x old-max-y)
335     (declare (ignore child old-min-x old-min-y old-max-x old-max-y))
336     (let ((old-rectangle (multiple-value-call #'make-bounding-rectangle
337     (bounding-rectangle* record))))
338     (call-next-method)
339     (with-slots (parent x1 y1 x2 y2) record
340 adejneka 1.21 (when (and parent (not (region-equal old-rectangle record)))
341 rouanet 1.11 (recompute-extent-for-changed-child parent record x1 y1 x2 y2)))))
342    
343     (defmethod recompute-extent-for-changed-child ((record output-record) changed-child
344 mikemac 1.1 old-min-x old-min-y old-max-x old-max-y)
345 rouanet 1.11 (with-slots (children x1 y1 x2 y2) record
346     (with-bounding-rectangle* (new-x1 new-y1 new-x2 new-y2) changed-child
347     (setq x1 (min x1 new-x1)
348     y1 (min y1 new-y1)
349     x2 (max x2 new-x2)
350     y2 (max y2 new-y2)))
351     (if (null children)
352     (clear-output-record record)
353     (when (or (coordinate= x1 old-min-x)
354     (coordinate= y1 old-min-y)
355     (coordinate= x2 old-max-x)
356     (coordinate= y2 old-max-y))
357     (with-bounding-rectangle* (left top right bottom) (first children)
358     (loop for child in (rest children)
359     do (with-bounding-rectangle* (x1-child y1-child x2-child y2-child) child
360     (setq left (min left x1-child)
361     top (min top y1-child)
362     right (max right x2-child)
363     bottom (max bottom y2-child))))
364     (setq x1 left
365     y1 top
366     x2 right
367     y2 bottom))))))
368 mikemac 1.1
369     (defmethod tree-recompute-extent ((record output-record))
370 adejneka 1.22 (with-slots (children x1 y1 x2 y2) record
371 mikemac 1.1 (if (null children)
372 adejneka 1.21 (setq x1 (coordinate 0)
373     y1 (coordinate 0)
374     x2 (coordinate 0)
375     y2 (coordinate 0))
376 mikemac 1.1 (with-bounding-rectangle* (left top right bottom) (first children)
377     (loop for child in (rest children)
378     do (with-bounding-rectangle* (l1 t1 r1 b1) child
379     (setq left (min left l1 r1)
380     top (min top t1 b1)
381     right (max right l1 r1)
382     bottom (max bottom t1 b1))))
383 cvs 1.3 (setq x1 left
384     y1 top
385     x2 right
386 adejneka 1.22 y2 bottom)))))
387    
388     (defmethod tree-recompute-extent :around ((record output-record))
389     (let ((old-rectangle (multiple-value-call #'make-bounding-rectangle
390     (bounding-rectangle* record))))
391     (call-next-method)
392     (with-slots (parent x1 y1 x2 y2) record
393     (when (and parent (not (region-equal old-rectangle record)))
394     (recompute-extent-for-changed-child parent record x1 y1 x2 y2)))))
395 mikemac 1.1
396    
397     ;;; Graphics recording classes
398    
399     (defclass graphics-displayed-output-record (displayed-output-record)
400 adejneka 1.14 ((clip :initarg :clipping-region
401     :documentation "Clipping region in user coordinates.")
402 mikemac 1.1 (transform :initarg :transformation)
403     (line-style :initarg :line-style)
404     (text-style :initarg :text-style)
405     ))
406    
407     (defun graphics-displayed-output-record-p (x)
408     (typep x 'graphics-displayed-output-record))
409    
410    
411     ;;; stream-output-history-mixin class
412    
413     (defclass stream-output-history-mixin ()
414 rouanet 1.11 ())
415    
416     (defclass standard-sequence-output-history (standard-sequence-output-record stream-output-history-mixin)
417     ())
418    
419     (defclass standard-tree-output-history (standard-tree-output-record stream-output-history-mixin)
420     ())
421    
422    
423     ;;; Output-Recording-Stream class
424    
425     (defclass output-recording-stream ()
426     ((recording-p :initform t :accessor stream-recording-p)
427     (drawing-p :initform t :accessor stream-drawing-p)
428     (output-history :initform (make-instance 'standard-tree-output-history)
429     :reader stream-output-history)
430 adejneka 1.20 (current-output-record :accessor stream-current-output-record)
431     (current-text-output-record :initform nil :accessor stream-current-text-output-record)
432     (local-record-p :initform t
433     :documentation "This flag is used for dealing with streams outputting strings char-by-char.")))
434 rouanet 1.11
435     (defun output-recording-stream-p (x)
436     (typep x 'output-recording-stream))
437    
438     (defclass standard-output-recording-stream (output-recording-stream)
439     (
440 mikemac 1.1 ))
441    
442 adejneka 1.21 ;;; 16.4.1 The Output Recording Stream Protocol
443     (defgeneric stream-recording-p (stream))
444 adejneka 1.22
445 adejneka 1.21 (defgeneric (setf stream-recording-p) (recording-p stream))
446 adejneka 1.22
447 adejneka 1.21 (defgeneric stream-drawing-p (stream))
448 adejneka 1.22
449 adejneka 1.21 (defgeneric (setf stream-drawing-p) (drawing-p stream))
450 adejneka 1.22
451 adejneka 1.21 (defgeneric stream-output-history (stream))
452 adejneka 1.22
453 adejneka 1.21 (defgeneric stream-current-output-record (stream))
454 adejneka 1.22
455 adejneka 1.21 (defgeneric (setf stream-current-output-record) (record stream))
456 adejneka 1.22
457 adejneka 1.21 (defgeneric stream-add-output-record (stream record))
458 adejneka 1.22
459 adejneka 1.21 (defgeneric stream-replay (stream &optional region))
460 adejneka 1.22
461 adejneka 1.21 (defgeneric erase-output-record (record stream &optional (errorp t)))
462 adejneka 1.22
463 adejneka 1.21 (defgeneric copy-textual-output-history (window stream &optional region record))
464    
465     ;;; 16.4.3 Text Output Recording
466 adejneka 1.22
467 adejneka 1.21 (defgeneric stream-text-output-record (stream text-style))
468 adejneka 1.22
469 adejneka 1.21 (defgeneric stream-close-text-output-record (stream))
470 adejneka 1.22
471 adejneka 1.21 (defgeneric stream-add-character-output
472     (stream character text-style width height baseline))
473 adejneka 1.22
474 adejneka 1.21 (defgeneric stream-add-string-output
475     (stream string start end text-style width height baseline))
476    
477     ;;; Methods
478 rouanet 1.11 (defmethod initialize-instance :after ((stream output-recording-stream) &rest args)
479     (declare (ignore args))
480     (setf (stream-current-output-record stream) (stream-output-history stream)))
481    
482     (defmethod stream-add-output-record ((stream output-recording-stream) record)
483 adejneka 1.16 (add-output-record record (stream-current-output-record stream)))
484 rouanet 1.11
485     (defmethod stream-replay ((stream output-recording-stream) &optional region)
486     (replay (stream-output-history stream) stream region))
487    
488 cvs 1.10 (defmacro with-output-recording-options ((stream &key (record t) (draw t)) &body body)
489 adejneka 1.16 (declare (type symbol stream))
490     (when (eq stream 't)
491 rouanet 1.18 (setq stream '*standard-output*))
492 adejneka 1.16 (let ((continuation-name (gensym)))
493     `(let ((,continuation-name #'(lambda (,stream) ,@body)))
494     (invoke-with-output-recording-options ,stream
495     ,continuation-name
496     ,record
497     ,draw))))
498    
499     (defmethod invoke-with-output-recording-options
500     ((stream output-recording-stream) continuation record draw)
501     "Calls CONTINUATION on STREAM enabling or disabling recording and drawing
502     according to the flags RECORD and DRAW."
503 rouanet 1.18 (declare (dynamic-extent continuation))
504 adejneka 1.16 (with-slots (recording-p drawing-p) stream
505 adejneka 1.22 (unless (eq recording-p record)
506     (stream-close-text-output-record stream))
507     (letf ((recording-p record)
508     (drawing-p draw))
509     (funcall continuation stream))))
510 adejneka 1.16
511     (defmacro with-new-output-record ((stream
512     &optional
513 rouanet 1.18 (record-type 'standard-sequence-output-record)
514 adejneka 1.16 (record nil record-supplied-p)
515     &rest initargs)
516     &body body)
517     "Creates a new output record of type RECORD-TYPE and then captures
518     the output of BODY into the new output record, and inserts the new
519     record into the current \"open\" output record assotiated with STREAM.
520     If RECORD is supplied, it is the name of a variable that will be
521     lexically bound to the new output record inside the body. INITARGS are
522     CLOS initargs that are passed to MAKE-INSTANCE when the new output
523     record is created.
524     It returns the created output record.
525     The STREAM argument is a symbol that is bound to an output
526     recording stream. If it is T, *STANDARD-OUTPUT* is used."
527     (declare (type symbol stream record))
528     (when (eq stream 't)
529     (setq stream '*standard-output*))
530     (unless record-supplied-p
531     (setq record (gensym)))
532     `(invoke-with-new-output-record
533     ,stream
534     #'(lambda (,stream ,record)
535 adejneka 1.19 ,@(unless record-supplied-p `((declare (ignore ,record))))
536 adejneka 1.16 ,@body)
537 rouanet 1.18 ',record-type
538 adejneka 1.16 ,@initargs))
539    
540     (defmethod invoke-with-new-output-record ((stream output-recording-stream)
541     continuation record-type
542     &rest initargs
543     &key parent)
544 adejneka 1.20 (stream-close-text-output-record stream)
545 adejneka 1.16 (unless parent
546     (setq parent (stream-current-output-record stream)))
547 adejneka 1.22 (let ((new-record (apply #'make-instance record-type :parent parent initargs)))
548     (letf (((stream-current-output-record stream) new-record))
549     (funcall continuation stream new-record)
550     (finish-output stream))
551     (stream-add-output-record stream new-record)
552 adejneka 1.16 new-record))
553 cvs 1.10
554 rouanet 1.11 (defmethod scroll-vertical :around ((stream output-recording-stream) dy)
555 mikemac 1.1 (declare (ignore dy))
556     (with-output-recording-options (stream :record nil)
557     (call-next-method)))
558    
559 rouanet 1.11 (defmethod scroll-horizontal :around ((stream output-recording-stream) dx)
560 mikemac 1.1 (declare (ignore dx))
561     (with-output-recording-options (stream :record nil)
562     (call-next-method)))
563    
564 rouanet 1.11 (defmethod repaint-sheet ((stream output-recording-stream) region)
565     (stream-replay stream region))
566 cvs 1.7
567 rouanet 1.11 (defmethod handle-event ((stream output-recording-stream) (event window-repaint-event))
568 rouanet 1.12 (repaint-sheet stream (window-event-region event)))
569 cvs 1.7
570 rouanet 1.11 (defmethod handle-event ((stream output-recording-stream) (event pointer-button-press-event))
571 cvs 1.7 (with-slots (button x y) event
572     (format *debug-io* "button ~D pressed at ~D,~D~%" button x y)))
573    
574 rouanet 1.11 #|
575     (defmethod handle-event :after ((stream output-recording-stream) (event pointer-button-press-event))
576 rouanet 1.18 (highlight-output-record (stream-current-output-record stream) stream :highlight))
577 rouanet 1.11
578     (defmethod handle-event :before ((stream output-recording-stream) (event pointer-button-release-event))
579 rouanet 1.18 (highlight-output-record (stream-current-output-record stream) stream :unhighlight))
580 rouanet 1.11 |#
581 mikemac 1.1
582    
583 adejneka 1.21 ;;; Graphics and text recording classes
584 mikemac 1.1
585     (eval-when (compile load eval)
586    
587     (defun compute-class-vars (names)
588     (cons (list 'stream :initarg :stream)
589     (loop for name in names
590 cvs 1.2 collecting (list name :initarg (intern (symbol-name name) :keyword)))))
591 mikemac 1.1
592     (defun compute-arg-list (names)
593     (loop for name in names
594 cvs 1.2 nconcing (list (intern (symbol-name name) :keyword) name)))
595 mikemac 1.1 )
596    
597     (defun make-merged-medium (sheet ink clip transform line-style text-style)
598     (let ((medium (make-medium (port sheet) sheet)))
599     (setf (medium-ink medium) ink)
600 adejneka 1.14 ;; First set transformation, then clipping region!
601     (setf (medium-transformation medium) transform)
602 mikemac 1.1 (setf (medium-clipping-region medium) clip)
603     (setf (medium-line-style medium) line-style)
604     (setf (medium-text-style medium) text-style)
605     medium))
606    
607     (defmacro def-grecording (name (&rest args) &body body)
608     (let ((method-name (intern (format nil "MEDIUM-~A*" name)))
609     (class-name (intern (format nil "~A-OUTPUT-RECORD" name)))
610     (old-medium (gensym))
611 rouanet 1.12 (new-medium (gensym))
612     (border (gensym)))
613 cvs 1.10 `(progn
614 mikemac 1.1 (defclass ,class-name (graphics-displayed-output-record)
615     ,(compute-class-vars args))
616     (defmethod initialize-instance :after ((graphic ,class-name) &rest args)
617     (declare (ignore args))
618 rouanet 1.18 (with-slots (x y x1 y1 x2 y2 initial-x1 initial-y1
619 adejneka 1.14 stream ink clipping-region transform
620 mikemac 1.1 line-style text-style
621     ,@args) graphic
622 rouanet 1.12 (let ((,border (1+ (/ (line-style-thickness line-style) 2))))
623     (multiple-value-bind (lf tp rt bt) (progn ,@body)
624     (setq x1 (- lf ,border)
625     y1 (- tp ,border)
626     x2 (+ rt ,border)
627 rouanet 1.18 y2 (+ bt ,border))))
628     (setf x x1
629     y y1
630     initial-x1 x1
631     initial-y1 y1)))
632 rouanet 1.11 (defmethod ,method-name :around ((stream output-recording-stream) ,@args)
633 mikemac 1.1 (with-sheet-medium (medium stream)
634 cvs 1.5 (when (stream-recording-p stream)
635     (let ((record (make-instance ',class-name
636     :stream stream
637     :ink (medium-ink medium)
638     :clipping-region (medium-clipping-region medium)
639     :transformation (medium-transformation medium)
640     :line-style (medium-line-style medium)
641     :text-style (medium-text-style medium)
642     ,@(compute-arg-list args))))
643 rouanet 1.11 (stream-add-output-record stream record)))
644 cvs 1.5 (when (stream-drawing-p stream)
645     (call-next-method))))
646 mikemac 1.1 (defmethod replay-output-record ((record ,class-name) stream
647 rouanet 1.18 &optional (region +everywhere+)
648     (x-offset 0) (y-offset 0))
649     (with-slots (x y initial-x1 initial-y1
650     ink clip transform line-style text-style ,@args) record
651     (let ((transformation (compose-translation-with-transformation
652     transform
653     (+ (- x initial-x1) x-offset)
654     (+ (- y initial-y1) y-offset))))
655     (let ((,old-medium (sheet-medium stream))
656     (,new-medium (make-merged-medium stream ink
657     (region-intersection clip
658     (untransform-region transformation region))
659     transformation line-style text-style)))
660     (unwind-protect
661     (progn
662     (setf (sheet-medium stream) ,new-medium)
663     (setf (medium-sheet ,new-medium) stream)
664     (,method-name ,new-medium ,@args))
665     (setf (sheet-medium stream) ,old-medium)))))))))
666 mikemac 1.1
667 rouanet 1.11 (def-grecording draw-point (point-x point-y)
668 adejneka 1.14 (with-transformed-position (transform point-x point-y)
669     (values point-x point-y point-x point-y)))
670 mikemac 1.1
671     (def-grecording draw-points (coord-seq)
672 adejneka 1.14 (with-transformed-positions (transform coord-seq)
673     (loop for (x y) on coord-seq by #'cddr
674     minimize x into min-x
675     minimize y into min-y
676     maximize x into max-x
677     maximize y into max-y
678     finally (return (values min-x min-y max-x max-y)))))
679 mikemac 1.1
680 rouanet 1.11 (def-grecording draw-line (point-x1 point-y1 point-x2 point-y2)
681 adejneka 1.14 (with-transformed-position (transform point-x1 point-y1)
682     (with-transformed-position (transform point-x2 point-y2)
683     (values (min point-x1 point-x2) (min point-y1 point-y2)
684     (max point-x1 point-x2) (max point-y1 point-y2)))))
685 mikemac 1.1
686     (def-grecording draw-lines (coord-seq)
687 adejneka 1.14 (with-transformed-positions (transform coord-seq)
688     (loop for (x y) on coord-seq by #'cddr
689     minimize x into min-x
690     minimize y into min-y
691     maximize x into max-x
692     maximize y into max-y
693     finally (return (values min-x min-y max-x max-y)))))
694 mikemac 1.1
695     (def-grecording draw-polygon (coord-seq closed filled)
696 adejneka 1.16 ;; FIXME !!!
697     ;; If LINE-STYLE-JOINT-SHAPE is :MITTER, then the bb is larger than
698     ;; these numbers by (LINE-THICKNESS / (sin (angle / 2))),
699     ;; which is larger than LINE-THICKNESS
700 adejneka 1.14 (with-transformed-positions (transform coord-seq)
701     (loop for (x y) on coord-seq by #'cddr
702     minimize x into min-x
703     minimize y into min-y
704     maximize x into max-x
705     maximize y into max-y
706     finally (return (values min-x min-y max-x max-y)))))
707 mikemac 1.1
708     (def-grecording draw-rectangle (left top right bottom filled)
709 adejneka 1.17 ;; FIXME!!! If the rectangle is a line/point, MAKE-RECTANGLE* gives +NOWHERE+,
710     ;; and BOUNDING-RECTANGLE* signals an error.
711     (bounding-rectangle* (transform-region transform
712     (make-rectangle* left top right bottom))))
713 mikemac 1.1
714     (def-grecording draw-ellipse (center-x center-y
715     radius-1-dx radius-1-dy radius-2-dx radius-2-dy
716     start-angle end-angle filled)
717 adejneka 1.17 (bounding-rectangle* (transform-region transform
718     (make-ellipse* center-x center-y
719     radius-1-dx radius-1-dy radius-2-dx radius-2-dy
720     :start-angle start-angle
721     :end-angle end-angle))))
722 rouanet 1.11
723     (def-grecording draw-text (string point-x point-y start end
724     align-x align-y toward-x toward-y transform-glyphs)
725 adejneka 1.16 ;; FIXME!!! transformation
726 rouanet 1.11 (let* ((width (stream-string-width stream string
727     :start start :end end
728     :text-style text-style))
729     (ascent (text-style-ascent text-style (port (sheet-medium stream))))
730     (descent (text-style-descent text-style (port (sheet-medium stream))))
731     (height (+ ascent descent))
732     left top right bottom)
733     (ecase align-x
734     (:left (setq left point-x
735     right (+ point-x width)))
736     (:right (setq left (- point-x width)
737     right point-x))
738     (:center (setq left (- point-x (round width 2))
739     right (+ point-x (round width 2)))))
740     (ecase align-y
741     (:baseline (setq top (- point-y height)
742     bottom (+ point-y descent)))
743     (:top (setq top point-y
744     bottom (+ point-y height)))
745     (:bottom (setq top (- point-y height)
746     bottom point-y))
747     (:center (setq top (- point-y (floor height 2))
748     bottom (+ point-y (ceiling height 2)))))
749     (values left top right bottom)))
750 mikemac 1.1
751    
752     ;;; Text recording class
753    
754     (defclass text-displayed-output-record (displayed-output-record)
755     ((strings :initform nil)
756     (baseline :initform 0)
757 adejneka 1.22 (width :initform 0)
758 mikemac 1.1 (max-height :initform 0)
759 cvs 1.6 (start-x :initarg :start-x)
760     (start-y :initarg :start-y)
761 mikemac 1.1 (end-x)
762 cvs 1.8 (end-y)
763     (wrapped :initform nil
764 adejneka 1.21 :accessor text-record-wrapped)))
765 mikemac 1.1
766     (defun text-displayed-output-record-p (x)
767     (typep x 'text-displayed-output-record))
768    
769 cvs 1.8 (defmethod print-object ((self text-displayed-output-record) stream)
770     (print-unreadable-object (self stream :type t :identity t)
771     (if (slot-boundp self 'start-x)
772     (with-slots (start-x start-y strings) self
773     (format stream "~D,~D ~S" start-x start-y (mapcar #'third strings)))
774     (format stream "empty"))))
775 mikemac 1.1
776 adejneka 1.21 (defgeneric add-character-output-to-text-record
777     (text-record character text-style width height baseline))
778     (defgeneric add-string-output-to-text-record
779     (text-record string start end text-style width height baseline))
780     (defgeneric text-displayed-output-record-string (text-record))
781    
782     ;;; Methods
783 cvs 1.9 (defmethod tree-recompute-extent ((text-record text-displayed-output-record))
784 adejneka 1.22 (with-slots (parent x y
785     x1 y1 x2 y2 width max-height) text-record
786     (setq x1 (coordinate x)
787     y1 (coordinate y)
788     x2 (coordinate (+ x width))
789     y2 (coordinate (+ y max-height)))))
790    
791 rouanet 1.23 (defmethod* (setf output-record-position) :before (nx ny (record text-displayed-output-record))
792 adejneka 1.22 (with-slots (x1 y1 x2 y2 x y start-x start-y end-x end-y) record
793 rouanet 1.23 (let ((dx (- nx x))
794     (dy (- ny y)))
795     (incf start-x dx)
796     (incf start-y dy)
797     (incf end-x dx)
798     (incf end-y dy))))
799 cvs 1.9
800 mikemac 1.1 (defmethod add-character-output-to-text-record ((text-record text-displayed-output-record)
801 adejneka 1.22 character text-style char-width height
802 mikemac 1.1 new-baseline)
803 adejneka 1.22 (with-slots (strings baseline width max-height start-y end-x end-y) text-record
804 cvs 1.7 (if (and strings (eq (second (first (last strings))) text-style))
805     (vector-push-extend character (third (first (last strings))))
806     (setq strings (nconc strings (list (list end-x text-style (make-array 1 :initial-element character :element-type 'character :adjustable t :fill-pointer t))))))
807     (setq baseline (max baseline new-baseline)
808 adejneka 1.22 end-x (+ end-x char-width)
809 mikemac 1.1 max-height (max max-height height)
810 cvs 1.9 end-y (max end-y (+ start-y max-height))
811 adejneka 1.22 width (+ width char-width)))
812 cvs 1.9 (tree-recompute-extent text-record))
813 mikemac 1.1
814     (defmethod add-string-output-to-text-record ((text-record text-displayed-output-record)
815 adejneka 1.22 string start end text-style string-width height
816 mikemac 1.1 new-baseline)
817 adejneka 1.20 (if end
818 adejneka 1.21 (setq end (min end (1- (length string))))
819 adejneka 1.20 (setq end (1- (length string))))
820     (let ((length (max 0 (- (1+ end) start))))
821     (setq string (make-array length :displaced-to string :displaced-index-offset start))
822 adejneka 1.22 (with-slots (strings baseline width max-height start-y end-x end-y) text-record
823 adejneka 1.20 (setq baseline (max baseline new-baseline)
824     strings (nconc strings (list (list end-x text-style (make-array (length string) :initial-contents string :element-type 'character :adjustable t :fill-pointer t))))
825 adejneka 1.22 end-x (+ end-x string-width)
826 adejneka 1.20 max-height (max max-height height)
827     end-y (max end-y (+ start-y max-height))
828 adejneka 1.22 width (+ width string-width))))
829 adejneka 1.20 (tree-recompute-extent text-record))
830 mikemac 1.1
831     (defmethod replay-output-record ((record text-displayed-output-record) stream
832 adejneka 1.21 &optional region (x-offset 0) (y-offset 0))
833 adejneka 1.20 (with-slots (strings baseline max-height start-x start-y wrapped
834 adejneka 1.21 x y x1 y1 initial-x1 initial-y1) record
835 cvs 1.7 (let ((old-medium (sheet-medium stream))
836     (new-medium (make-medium (port stream) stream)))
837     (unwind-protect
838 adejneka 1.22 (progn
839     (setf (sheet-medium stream) new-medium)
840     (setf (medium-sheet new-medium) stream)
841     (setf (medium-transformation new-medium)
842 adejneka 1.20 (make-translation-transformation
843 adejneka 1.22 x-offset
844     y-offset))
845    
846 rouanet 1.23 (setf (stream-cursor-position stream) (values start-x start-y))
847 adejneka 1.22 (letf (((slot-value stream 'baseline) baseline))
848     (loop for (x text-style string) in strings
849     do (setf (medium-text-style new-medium) text-style)
850 rouanet 1.23 (setf (stream-cursor-position stream)
851     (values (+ x (- x1 initial-x1)) start-y))
852 adejneka 1.22 (stream-write-line stream string)))
853     ;; clipping region
854     #|restore cursor position? set to (end-x,end-y)?|#
855     #+nil(loop for y = (+ start-y baseline)
856     for (x text-style string) in strings
857     do (setf (medium-text-style new-medium) text-style)
858     (draw-text* (sheet-medium stream) string x y
859     :text-style text-style :clipping-region (untransform-region (medium-transformation new-medium) region)))
860     (if wrapped
861     (draw-rectangle* (sheet-medium stream)
862     (+ wrapped 0) start-y (+ wrapped 4) (+ start-y max-height)
863     :ink +foreground-ink+
864     :filled t)))
865     (setf (sheet-medium stream) old-medium)))))
866 mikemac 1.1
867     (defmethod output-record-start-cursor-position ((record text-displayed-output-record))
868     (with-slots (start-x start-y) record
869     (values start-x start-y)))
870    
871     (defmethod output-record-end-cursor-position ((record text-displayed-output-record))
872     (with-slots (end-x end-y) record
873     (values end-x end-y)))
874    
875     (defmethod text-displayed-output-record-string ((record text-displayed-output-record))
876     (with-slots (strings) record
877     (loop for result = ""
878     for s in strings
879     do (setq result (concatenate 'string result (third s)))
880     finally (return result))))
881 cvs 1.5
882    
883 adejneka 1.21 ;;; Methods for text output to output recording streams
884 adejneka 1.22 (defmethod stream-text-output-record ((stream standard-output-recording-stream) text-style)
885 adejneka 1.20 (let ((record (stream-current-text-output-record stream)))
886     (unless record
887     (setf (stream-current-text-output-record stream)
888     (setq record (make-instance 'text-displayed-output-record)))
889 adejneka 1.22 (with-slots (start-x start-y end-x end-y x1 y1 x2 y2 x y
890 adejneka 1.20 initial-x1 initial-y1) record
891 cvs 1.8 (multiple-value-bind (cx cy) (stream-cursor-position stream)
892 adejneka 1.22 (setq start-x cx
893     start-y cy
894 cvs 1.8 end-x start-x
895 cvs 1.9 end-y start-y
896 adejneka 1.22 x1 (coordinate start-x)
897     x2 (coordinate end-x)
898     y1 (coordinate start-y)
899     y2 (coordinate end-y)
900 adejneka 1.20 initial-x1 x1
901 adejneka 1.22 initial-y1 y1
902     x start-x
903     y start-y))))
904 adejneka 1.20 record))
905    
906 adejneka 1.22 (defmethod stream-close-text-output-record ((stream standard-output-recording-stream))
907 adejneka 1.20 (let ((record (stream-current-text-output-record stream)))
908     (when record
909     (setf (stream-current-text-output-record stream) nil)
910     #|record stream-current-cursor-position to (end-x record) - already done|#
911     (stream-add-output-record stream record))))
912    
913 adejneka 1.22 (defmethod stream-add-character-output ((stream standard-output-recording-stream)
914 adejneka 1.20 character text-style
915     width height baseline)
916     (add-character-output-to-text-record (stream-text-output-record stream text-style)
917     character text-style width height baseline))
918    
919 adejneka 1.22 (defmethod stream-add-string-output ((stream standard-output-recording-stream)
920 adejneka 1.20 string start end text-style
921     width height baseline)
922     (add-string-output-to-text-record (stream-text-output-record stream text-style)
923     string start end text-style
924     width height baseline))
925    
926     (defmacro without-local-recording (stream &body body)
927 adejneka 1.22 `(letf (((slot-value ,stream 'local-record-p) nil))
928     ,@body))
929    
930     (defmethod stream-write-line :around ((stream standard-output-recording-stream) line)
931     (when (and (stream-recording-p stream)
932     (slot-value stream 'local-record-p))
933     (let* ((medium (sheet-medium stream))
934     (text-style (medium-text-style medium))
935     (port (port stream)))
936     (stream-add-string-output stream line 0 nil text-style
937     (stream-string-width stream line
938     :text-style text-style)
939     (text-style-height text-style port)
940     (text-style-ascent text-style port))))
941     (when (stream-drawing-p stream)
942     (without-local-recording stream
943     (call-next-method))))
944 cvs 1.5
945 adejneka 1.22 #+nil
946     (defmethod stream-write-char :around ((stream standard-output-recording-stream) char)
947 adejneka 1.20 (when (and (stream-recording-p stream)
948     (slot-value stream 'local-record-p))
949     (if (or (eql char #\return)
950     (eql char #\newline))
951     (stream-close-text-output-record stream)
952 cvs 1.8 (let* ((medium (sheet-medium stream))
953 adejneka 1.20 (text-style (medium-text-style medium))
954     (port (port stream)))
955     (stream-add-character-output stream char text-style
956     (stream-character-width stream char :text-style text-style)
957     (text-style-height text-style port)
958     (text-style-ascent text-style port)))))
959     (without-local-recording stream
960     (call-next-method)))
961    
962 adejneka 1.21 #+nil
963 adejneka 1.22 (defmethod stream-write-string :around ((stream standard-output-recording-stream) string
964 adejneka 1.20 &optional (start 0) end)
965 adejneka 1.21 ;; Problem: it is necessary to check for line wrapping. Now the
966     ;; default method for STREAM-WRITE-STRING do char-by-char output,
967     ;; therefore STREAM-WRITE-CHAR can do the right thing.
968 adejneka 1.20 (when (and (stream-recording-p stream)
969     (slot-value stream 'local-record-p))
970     (let* ((medium (sheet-medium stream))
971     (text-style (medium-text-style medium))
972     (port (port stream)))
973     (stream-add-string-output stream string start end text-style
974     (stream-string-width stream string
975     :start start :end end
976     :text-style text-style)
977     (text-style-height text-style port)
978     (text-style-ascent text-style port))))
979     (without-local-recording stream
980     (call-next-method)))
981    
982    
983 adejneka 1.22 (defmethod stream-finish-output :after ((stream standard-output-recording-stream))
984 adejneka 1.20 (stream-close-text-output-record stream))
985    
986 adejneka 1.22 (defmethod stream-force-output :after ((stream standard-output-recording-stream))
987 adejneka 1.20 (stream-close-text-output-record stream))
988    
989 adejneka 1.22 (defmethod stream-terpri :after ((stream standard-output-recording-stream))
990 adejneka 1.21 (stream-close-text-output-record stream))
991    
992 rouanet 1.23 (defmethod* (setf stream-cursor-position) :after (x y (stream standard-output-recording-stream))
993 adejneka 1.20 (stream-close-text-output-record stream))
994    
995 adejneka 1.22 ;(defmethod stream-set-cursor-position :after ((stream standard-output-recording-stream))
996 adejneka 1.20 ; (stream-close-text-output-record stream))
997 cvs 1.5
998 adejneka 1.22 (defmethod stream-wrap-line :before ((stream standard-output-recording-stream))
999 cvs 1.5 (when (stream-recording-p stream)
1000 adejneka 1.20 (setf (text-record-wrapped (stream-text-output-record stream nil)) ; FIXME!
1001     (stream-text-margin stream))))

  ViewVC Help
Powered by ViewVC 1.1.5