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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.45 - (hide annotations)
Sun Jun 9 15:37:51 2002 UTC (11 years, 10 months ago) by adejneka
Branch: MAIN
Changes since 1.44: +3 -0 lines
* Added some comments
1 mikemac 1.1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2    
3 mikemac 1.29 ;;; (c) copyright 1998,1999,2000,2001 by Michael McDonald (mikemac@mikemac.com)
4 adejneka 1.41 ;;; (c) copyright 2000 by
5 cvs 1.4 ;;; Robert Strandh (strandh@labri.u-bordeaux.fr)
6 adejneka 1.41 ;;; (c) copyright 2001 by
7 rouanet 1.11 ;;; Arnaud Rouanet (rouanet@emi.u-bordeaux.fr)
8     ;;; Lionel Salabartan (salabart@emi.u-bordeaux.fr)
9 adejneka 1.41 ;;; (c) copyright 2001, 2002 by 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 adejneka 1.41 ;;; License along with this library; if not, write to the
23     ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 mikemac 1.1 ;;; 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.41 ;;; - When DRAWING-P is NIL, should stream cursor move?
33 adejneka 1.22 ;;; - OUTPUT-RECORD is a protocol class, it should not have any slots/methods.
34 adejneka 1.45 ;;; - TEXT-DISPLAYED-OUTPUT-RECORD-MIXIN does not store current ink.
35     ;;; - There are glitches with O-R-POSITION.
36 adejneka 1.22
37 mikemac 1.1 (in-package :CLIM-INTERNALS)
38    
39 moore 1.34 ;;; Should we blow off standard-bounding-rectangle and implement the
40     ;;; bounding rectangle protocol ourselves? Or use x1,y1 from
41     ;;; standard-bounding-rectangle as our position?
42    
43     (defclass basic-output-record (bounding-rectangle)
44     ()
45     (:documentation "Internal protocol class for common elements of output-record
46     and displayed-output-record"))
47    
48     (defclass basic-output-record-mixin (standard-bounding-rectangle
49     basic-output-record)
50 mikemac 1.1 ((x :initarg :x-position
51 adejneka 1.22 :initform 0
52     :type rational)
53 mikemac 1.1 (y :initarg :y-position
54 adejneka 1.22 :initform 0
55     :type rational)
56 mikemac 1.1 (parent :initarg :parent
57 rouanet 1.11 :initform nil
58 moore 1.34 :reader output-record-parent))
59     (:documentation "Implementation class for the Basic Output Record Protocol"))
60 rouanet 1.11
61 moore 1.34 (defmethod initialize-instance :after ((record basic-output-record-mixin)
62     &rest args)
63 rouanet 1.13 (declare (ignore args))
64 moore 1.34 (with-slots (x y x1 y1 x2 y2) record
65     (setq x1 x
66     y1 y
67     x2 x
68     y2 y)))
69    
70     (defclass output-record (basic-output-record)
71     ())
72    
73     (defun output-record-p (x)
74     (typep x 'output-record))
75 rouanet 1.11
76 moore 1.34 (defclass output-record-mixin (basic-output-record-mixin output-record)
77 moore 1.39 ()
78 moore 1.34 (:documentation "Implementation class for output records i.e., those records
79     that have children."))
80 mikemac 1.1
81 moore 1.34 (defclass displayed-output-record (basic-output-record)
82     ())
83 mikemac 1.1
84 moore 1.34 (defclass displayed-output-record-mixin (basic-output-record-mixin
85     displayed-output-record)
86 rouanet 1.18 ((ink :initarg :ink :reader displayed-output-record-ink)
87     (initial-x1 :initarg :initial-x1)
88 moore 1.34 (initial-y1 :initarg :initial-y1))
89     (:documentation "Implementation class for displayed-output-record."))
90 mikemac 1.1
91     (defun displayed-output-record-p (x)
92     (typep x 'displayed-output-record))
93    
94 adejneka 1.21 ; 16.2.1. The Basic Output Record Protocol
95 mikemac 1.30 #+:cmu(declaim (ftype (function (output-record) (values rational rational))
96     output-record-position))
97 adejneka 1.22 (defgeneric output-record-position (record)
98     (:documentation
99     "Returns the x and y position of RECORD. The position is the
100     position of the upper-left corner of its bounding rectangle. The
101     position is relative to the stream, where (0,0) is (initially) the
102     upper-left corner of the stream."))
103    
104 rouanet 1.23 (defgeneric* (setf output-record-position) (x y record))
105 adejneka 1.22
106 mikemac 1.30 #+:cmu(declaim (ftype (function (output-record) (values integer integer))
107     output-record-start-cursor-position))
108 adejneka 1.22 (defgeneric output-record-start-cursor-position (record)
109     (:documentation
110     "Returns the x and y starting cursor position of RECORD. The
111     positions are relative to the stream, where (0,0) is (initially) the
112     upper-left corner of the stream."))
113    
114 rouanet 1.23 (defgeneric* (setf output-record-start-cursor-position) (x y record))
115 adejneka 1.22
116 mikemac 1.30 #+:cmu(declaim (ftype (function (output-record) (values integer integer))
117     output-record-end-cursor-position))
118 adejneka 1.22 (defgeneric output-record-end-cursor-position (record)
119     (:documentation
120     "Returns the x and y ending cursor position of RECORD. The
121     positions are relative to the stream, where (0,0) is (initially) the
122     upper-left corner of the stream."))
123    
124 rouanet 1.23 (defgeneric* (setf output-record-end-cursor-position) (x y record))
125 adejneka 1.22
126     (defgeneric output-record-parent (record)
127     (:documentation
128     "Returns the output record that is the parent of RECORD, or nil if
129     RECORD has no parent."))
130    
131 adejneka 1.21 (defgeneric replay-output-record (record stream
132 adejneka 1.22 &optional region x-offset y-offset)
133     (:documentation "Displays the output captured by RECORD on the
134     STREAM, exactly as it was originally captured. The current user
135     transformation, line style, text style, ink and clipping region of
136     STREAM are all ignored. Instead, these are gotten from the output
137     record.
138    
139     Only those records that overlap REGION are displayed."))
140    
141 adejneka 1.21 (defgeneric output-record-hit-detection-rectangle* (record))
142 adejneka 1.22
143 adejneka 1.21 (defgeneric output-record-refined-position-test (record x y))
144 adejneka 1.22
145 adejneka 1.21 (defgeneric highlight-output-record (record stream state))
146 adejneka 1.22
147 adejneka 1.21 (defgeneric displayed-output-record-ink (displayed-output-record))
148    
149     ; 16.2.2. Output Record "Database" Protocol
150 adejneka 1.22
151 adejneka 1.21 (defgeneric output-record-children (record))
152 adejneka 1.22
153 adejneka 1.21 (defgeneric add-output-record (child record))
154 adejneka 1.22
155 adejneka 1.21 (defgeneric delete-output-record (child record &optional (errorp t)))
156 adejneka 1.22
157 adejneka 1.21 (defgeneric clear-output-record (record))
158 adejneka 1.22
159 adejneka 1.21 (defgeneric output-record-count (record))
160 adejneka 1.22
161 adejneka 1.21 (defgeneric map-over-output-records-containing-position
162     (function record x y &optional x-offset y-offset &rest function-args))
163 adejneka 1.22
164 adejneka 1.21 (defgeneric map-over-output-records-overlapping-region
165     (function record region &optional x-offset y-offset &rest function-args))
166    
167 moore 1.34 ;;; From the Franz CLIM user's guide but not in the spec... clearly necessary.
168     (defgeneric map-over-output-records
169     (continuation record &optional x-offset y-offset &rest continuation-args))
170    
171 adejneka 1.21 ; 16.2.3. Output Record Change Notification Protocol
172 adejneka 1.22
173 adejneka 1.21 (defgeneric recompute-extent-for-new-child (record child))
174 adejneka 1.22
175 adejneka 1.21 (defgeneric recompute-extent-for-changed-child
176     (record child old-min-x old-min-y old-max-x old-max-y))
177 adejneka 1.22
178 adejneka 1.21 (defgeneric tree-recompute-extent (record))
179    
180     ;;; Methods
181 adejneka 1.22
182 moore 1.34 (defmethod output-record-position ((record basic-output-record-mixin))
183 mikemac 1.1 (with-slots (x y) record
184     (values x y)))
185    
186 moore 1.34 (defvar *suppress-notify-parent* nil
187     "When t, don't notify the parent of a change in an output record's
188     bounding rectangle.")
189    
190     (defmethod* (setf output-record-position)
191     (nx ny (record basic-output-record-mixin))
192 rouanet 1.18 (with-slots (x y x1 y1 x2 y2) record
193     (let ((dx (- nx x))
194     (dy (- ny y)))
195     (incf x1 dx) (incf y1 dy)
196     (incf x2 dx) (incf y2 dy))
197     (setq x nx
198     y ny)))
199 mikemac 1.1
200 moore 1.34 (defmethod* (setf output-record-position) :before
201     (nx ny (record output-record))
202     (let ((*suppress-notify-parent* t))
203     (multiple-value-bind (old-x old-y) (output-record-position record)
204 moore 1.39 (let ((dx (- nx old-x))
205     (dy (- ny old-y)))
206     (map-over-output-records
207     #'(lambda (child)
208     (multiple-value-bind (x y) (output-record-position child)
209     (setf (output-record-position child)
210     (values (+ x dx) (+ y dy)))))
211     record)))))
212 rouanet 1.11
213 moore 1.34 (defmethod* (setf output-record-position) :around
214     (nx ny (record basic-output-record))
215 rouanet 1.11 (declare (ignore nx ny))
216 moore 1.34 (if *suppress-notify-parent*
217     (call-next-method)
218     (with-bounding-rectangle* (min-x min-y max-x max-y) record
219     (call-next-method)
220     (let ((parent (output-record-parent record)))
221     (when parent
222     (recompute-extent-for-changed-child parent record
223     min-x min-y max-x max-y))))))
224    
225 rouanet 1.11
226 moore 1.34 (defmethod output-record-start-cursor-position ((record basic-output-record))
227 mikemac 1.1 (values nil nil))
228    
229 moore 1.34 (defmethod* (setf output-record-start-cursor-position)
230     (x y (record basic-output-record))
231 mikemac 1.1 (declare (ignore x y))
232     nil)
233    
234 moore 1.34 (defmethod output-record-end-cursor-position ((record basic-output-record))
235 mikemac 1.1 (values nil nil))
236    
237 moore 1.34 (defmethod* (setf output-record-end-cursor-position)
238     (x y (record basic-output-record))
239 mikemac 1.1 (declare (ignore x y))
240     nil)
241    
242 adejneka 1.24 (defun replay (record stream &optional region)
243 adejneka 1.21 (stream-close-text-output-record stream)
244 rouanet 1.11 (when (stream-drawing-p stream)
245 adejneka 1.22 (with-cursor-off stream
246     (multiple-value-bind (cx cy) (stream-cursor-position stream)
247     (unwind-protect
248     (letf (((stream-recording-p stream) nil))
249     (replay-output-record record stream region))
250 rouanet 1.23 (setf (stream-cursor-position stream) (values cx cy)))))))
251 mikemac 1.1
252     (defmethod replay-output-record ((record output-record) stream
253 rouanet 1.18 &optional region (x-offset 0) (y-offset 0))
254 rouanet 1.11 (when (null region)
255     (setq region +everywhere+))
256 moore 1.34 (map-over-output-records-overlapping-region
257 rouanet 1.11 #'replay-output-record record region x-offset y-offset
258     stream region x-offset y-offset))
259 mikemac 1.1
260 moore 1.34 ;;; XXX ? should this be defined on output-record at all?
261     ;;; Probably not -- moore
262 adejneka 1.41 (defmethod erase-output-record ((record output-record) stream
263     &optional (errorp t))
264 mikemac 1.30 (declare (ignore stream errorp))
265 mikemac 1.1 nil)
266    
267 moore 1.34 (defmethod output-record-hit-detection-rectangle*
268     ((record basic-output-record))
269 mikemac 1.1 (bounding-rectangle* record))
270    
271 moore 1.39 (defmethod output-record-refined-position-test ((record basic-output-record)
272     x y)
273 rouanet 1.13 (declare (ignore x y))
274     t)
275 mikemac 1.1
276 moore 1.34 ;;; XXX Should this only be defined on recording streams?
277     (defmethod highlight-output-record ((record basic-output-record-mixin)
278     stream state)
279 adejneka 1.45 ;; FIXME!!! WITH-IDENTITY-TRANSFORMATION
280 adejneka 1.41 (multiple-value-bind (x1 y1 x2 y2)
281     (output-record-hit-detection-rectangle* record)
282 mikemac 1.1 (ecase state
283     (:highlight
284 adejneka 1.41 (draw-rectangle* (sheet-medium stream) x1 y1 x2 y2
285     :filled nil :ink +foreground-ink+))
286 mikemac 1.1 (:unhighlight
287 adejneka 1.41 (draw-rectangle* (sheet-medium stream) x1 y1 x2 y2
288     :filled nil :ink +background-ink+)))))
289 rouanet 1.11
290 moore 1.34 (defclass standard-sequence-output-record (output-record-mixin)
291 moore 1.39 ((children :initform (make-array 8 :adjustable t :fill-pointer 0)
292     :reader output-record-children)))
293 rouanet 1.11
294 moore 1.39 ;;; XXX bogus for now.
295     (defclass standard-tree-output-record (standard-sequence-output-record)
296 rouanet 1.11 (
297     ))
298    
299 moore 1.34 #+nil
300 adejneka 1.41 (defmethod* (setf output-record-position)
301     (nx ny (record standard-sequence-output-record))
302 adejneka 1.21 (with-slots (x y) record
303 rouanet 1.23 (setq x nx
304     y ny)))
305 adejneka 1.21
306 moore 1.39 (defmethod add-output-record (child (record standard-sequence-output-record))
307 mikemac 1.1 (with-slots (children) record
308 moore 1.39 (vector-push-extend child children))
309 mikemac 1.1 (with-slots (parent) child
310     (setf parent record)))
311    
312 moore 1.34 (defmethod add-output-record :before (child (record output-record-mixin))
313 moore 1.39 (when (zerop (output-record-count record))
314 rouanet 1.11 (with-slots (x1 y1 x2 y2) record
315 strandh 1.37 (setf (values x1 y1 x2 y2) (bounding-rectangle* child)))))
316 rouanet 1.11
317     (defmethod add-output-record :after (child (record output-record))
318     (recompute-extent-for-new-child record child))
319    
320 moore 1.39 (defmethod delete-output-record (child (record standard-sequence-output-record)
321 moore 1.34 &optional (errorp t))
322 mikemac 1.1 (with-slots (children) record
323 moore 1.39 (let ((pos (position child children :test #'eq)))
324     (if (null pos)
325     (when errorp
326     (error "~S is not a child of ~S" child record))
327     (progn
328     (setq children (replace children children
329     :start1 pos
330     :start2 (1+ pos)))
331     (decf (fill-pointer children)))))))
332 mikemac 1.1
333 moore 1.34 (defmethod delete-output-record :after (child (record output-record-mixin)
334     &optional (errorp t))
335 rouanet 1.11 (declare (ignore errorp))
336     (with-bounding-rectangle* (x1 y1 x2 y2) child
337     (recompute-extent-for-changed-child record child x1 y1 x2 y2)))
338    
339 moore 1.39 (defmethod clear-output-record ((record standard-sequence-output-record))
340 cvs 1.3 (with-slots (children x1 y1 x2 y2) record
341 moore 1.39 (fill children nil)
342     (setf (fill-pointer children) 0)
343     (setq x2 x1
344 moore 1.34 y2 y1)))
345 mikemac 1.1
346 moore 1.39 (defmethod output-record-count ((record standard-sequence-output-record))
347 mikemac 1.1 (length (output-record-children record)))
348    
349 moore 1.39 (defmethod map-over-output-records
350     (function (record standard-sequence-output-record)
351 moore 1.35 &optional (x-offset 0) (y-offset 0)
352     &rest function-args)
353     (declare (ignore x-offset y-offset))
354 moore 1.39 (loop for child across (output-record-children record)
355     do (apply function child function-args)))
356 moore 1.35
357 moore 1.39 ;;; This needs to work in "most recently added first" order, which I
358     ;;; didn't know until recently :) -- moore
359 moore 1.35 (defmethod map-over-output-records-containing-position
360 moore 1.39 (function (record standard-sequence-output-record) x y
361 moore 1.35 &optional (x-offset 0) (y-offset 0)
362     &rest function-args)
363 moore 1.36 (declare (ignore x-offset y-offset))
364 moore 1.39 (with-slots (children) record
365     (loop for i from (1- (length children)) downto 0
366     for child = (aref children i)
367     when (and (multiple-value-bind (min-x min-y max-x max-y)
368     (output-record-hit-detection-rectangle* child)
369     (and (<= min-x x max-x) (<= min-y y max-y)))
370     (output-record-refined-position-test child x y))
371     do (apply function child function-args))))
372 mikemac 1.1
373 moore 1.35 (defmethod map-over-output-records-overlapping-region
374 moore 1.39 (function (record standard-sequence-output-record) region
375 moore 1.35 &optional (x-offset 0) (y-offset 0)
376     &rest function-args)
377     (declare (ignore x-offset y-offset))
378 moore 1.39 (loop for child across (output-record-children record)
379 rouanet 1.11 do (when (region-intersects-region-p region child)
380     (apply function child function-args))))
381 mikemac 1.1
382 moore 1.34 ;;; If the child is the only child of record, the record's bounding rectangle
383     ;;; is set to the child's.
384 moore 1.39 (defmethod recompute-extent-for-new-child
385     ((record standard-sequence-output-record) child)
386 rouanet 1.11 (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2) record
387 moore 1.34 (with-slots (parent children x1 y1 x2 y2) record
388 moore 1.39 (if (eql 1 (length children))
389 moore 1.34 (setf (values x1 y1 x2 y2) (bounding-rectangle* child))
390     (with-bounding-rectangle* (x1-child y1-child x2-child y2-child) child
391     (minf x1 x1-child)
392     (minf y1 y1-child)
393     (maxf x2 x2-child)
394     (maxf y2 y2-child)))
395 rouanet 1.11 (when parent
396 moore 1.34 (recompute-extent-for-changed-child parent record
397     old-x1 old-y1 old-x2 old-y2)))))
398 mikemac 1.1
399 moore 1.34 (defmethod recompute-extent-for-changed-child :around
400     ((record basic-output-record-mixin) child
401     old-min-x old-min-y old-max-x old-max-y)
402 rouanet 1.11 (declare (ignore child old-min-x old-min-y old-max-x old-max-y))
403     (let ((old-rectangle (multiple-value-call #'make-bounding-rectangle
404     (bounding-rectangle* record))))
405     (call-next-method)
406     (with-slots (parent x1 y1 x2 y2) record
407 adejneka 1.21 (when (and parent (not (region-equal old-rectangle record)))
408 rouanet 1.11 (recompute-extent-for-changed-child parent record x1 y1 x2 y2)))))
409    
410 moore 1.34 ;; Internal helper function
411     (defmethod %tree-recompute-extent* ((record output-record))
412     (let ((new-x1 0)
413     (new-y1 0)
414     (new-x2 0)
415     (new-y2 0)
416     (first-time t))
417     (map-over-output-records
418     #'(lambda (child)
419     (if first-time
420     (progn
421     (setf (values new-x1 new-y1 new-x2 new-y2)
422     (bounding-rectangle* child))
423     (setq first-time nil))
424     (with-bounding-rectangle* (cx1 cy1 cx2 cy2) child
425     (minf new-x1 cx1)
426     (minf new-y1 cy1)
427     (maxf new-x2 cx2)
428     (maxf new-y2 cy2))))
429     record)
430     ;; If we don't have any children, collapse the bbox to the min point.
431     (if first-time
432 moore 1.36 (multiple-value-bind (x1 y1)
433     (output-record-position record)
434 moore 1.34 (values x1 y1 x1 y1))
435     (values new-x1 new-y1 new-x2 new-y2))))
436    
437     (defmethod recompute-extent-for-changed-child
438     ((record output-record-mixin) changed-child
439     old-min-x old-min-y old-max-x old-max-y)
440     ;; If the child's old and new bbox lies entirely within the record's bbox
441     ;; then no change need be made to the record's bbox. Otherwise, if some part
442     ;; of the child's bbox was on the record's bbox and is now inside, examine
443     ;; all the children to determine the correct new bbox.
444     (with-slots (x1 y1 x2 y2) record
445     (with-bounding-rectangle* (child-x1 child-y1 child-x2 child-y2)
446     changed-child
447     (unless (and (> x1 old-min-x)
448     (> y1 old-min-y)
449     (< x2 old-max-x)
450     (< y2 old-max-y)
451     (> x1 child-x1)
452     (> y1 child-y1)
453     (< x2 child-x2)
454     (< y2 child-y2))
455     ;; Don't know if changed-child has been deleted or what, so go through
456     ;; all the children and construct the updated bbox.
457     (setf (values x1 y1 x2 y2) (%tree-recompute-extent* record))
458     nil))))
459    
460     (defmethod tree-recompute-extent ((record output-record-mixin))
461     (with-slots (x1 y1 x2 y2) record
462     (setf (values x1 y1 x2 y2) (%tree-recompute-extent* record))
463     nil))
464 mikemac 1.1
465 adejneka 1.22
466     (defmethod tree-recompute-extent :around ((record output-record))
467     (let ((old-rectangle (multiple-value-call #'make-bounding-rectangle
468     (bounding-rectangle* record))))
469     (call-next-method)
470     (with-slots (parent x1 y1 x2 y2) record
471 adejneka 1.41 (when (and parent (not (region-equal old-rectangle record)))
472     (recompute-extent-for-changed-child parent record x1 y1 x2 y2)))))
473 mikemac 1.1
474    
475     ;;; Graphics recording classes
476    
477     (defclass graphics-displayed-output-record (displayed-output-record)
478 moore 1.34 ())
479    
480     (defclass graphics-displayed-output-record-mixin
481     (displayed-output-record-mixin graphics-displayed-output-record)
482 adejneka 1.14 ((clip :initarg :clipping-region
483     :documentation "Clipping region in user coordinates.")
484 mikemac 1.1 (transform :initarg :transformation)
485     (line-style :initarg :line-style)
486     (text-style :initarg :text-style)
487     ))
488    
489     (defun graphics-displayed-output-record-p (x)
490     (typep x 'graphics-displayed-output-record))
491    
492    
493     ;;; stream-output-history-mixin class
494    
495     (defclass stream-output-history-mixin ()
496 rouanet 1.11 ())
497    
498 adejneka 1.41 (defclass standard-sequence-output-history
499     (standard-sequence-output-record stream-output-history-mixin)
500 rouanet 1.11 ())
501    
502 adejneka 1.41 (defclass standard-tree-output-history
503     (standard-tree-output-record stream-output-history-mixin)
504 rouanet 1.11 ())
505    
506    
507     ;;; Output-Recording-Stream class
508    
509     (defclass output-recording-stream ()
510 moore 1.34 ())
511    
512     (defun output-recording-stream-p (x)
513     (typep x 'output-recording-stream))
514    
515     (defclass standard-output-recording-stream (output-recording-stream)
516     ((recording-p :initform t :reader stream-recording-p)
517 rouanet 1.11 (drawing-p :initform t :accessor stream-drawing-p)
518     (output-history :initform (make-instance 'standard-tree-output-history)
519     :reader stream-output-history)
520 adejneka 1.20 (current-output-record :accessor stream-current-output-record)
521 adejneka 1.41 (current-text-output-record :initform nil
522     :accessor stream-current-text-output-record)
523 adejneka 1.20 (local-record-p :initform t
524     :documentation "This flag is used for dealing with streams outputting strings char-by-char.")))
525 rouanet 1.11
526 adejneka 1.21 ;;; 16.4.1 The Output Recording Stream Protocol
527     (defgeneric stream-recording-p (stream))
528 adejneka 1.22
529 adejneka 1.21 (defgeneric (setf stream-recording-p) (recording-p stream))
530 adejneka 1.22
531 adejneka 1.21 (defgeneric stream-drawing-p (stream))
532 adejneka 1.22
533 adejneka 1.21 (defgeneric (setf stream-drawing-p) (drawing-p stream))
534 adejneka 1.22
535 adejneka 1.21 (defgeneric stream-output-history (stream))
536 adejneka 1.22
537 adejneka 1.21 (defgeneric stream-current-output-record (stream))
538 adejneka 1.22
539 adejneka 1.21 (defgeneric (setf stream-current-output-record) (record stream))
540 adejneka 1.22
541 adejneka 1.21 (defgeneric stream-add-output-record (stream record))
542 adejneka 1.22
543 adejneka 1.21 (defgeneric stream-replay (stream &optional region))
544 adejneka 1.22
545 adejneka 1.21 (defgeneric erase-output-record (record stream &optional (errorp t)))
546 adejneka 1.22
547 adejneka 1.21 (defgeneric copy-textual-output-history (window stream &optional region record))
548    
549 moore 1.34 (defmethod (setf stream-recording-p)
550     (recording-p (stream standard-output-recording-stream))
551     (let ((old-val (slot-value stream 'recording-p)))
552     (setf (slot-value stream 'recording-p) recording-p)
553     (when (not (eql old-val recording-p))
554     (stream-close-text-output-record stream))
555     recording-p))
556    
557 adejneka 1.21 ;;; 16.4.3 Text Output Recording
558 adejneka 1.22
559 adejneka 1.21 (defgeneric stream-text-output-record (stream text-style))
560 adejneka 1.22
561 adejneka 1.21 (defgeneric stream-close-text-output-record (stream))
562 adejneka 1.22
563 adejneka 1.21 (defgeneric stream-add-character-output
564     (stream character text-style width height baseline))
565 adejneka 1.22
566 adejneka 1.21 (defgeneric stream-add-string-output
567     (stream string start end text-style width height baseline))
568    
569     ;;; Methods
570 rouanet 1.11 (defmethod initialize-instance :after ((stream output-recording-stream) &rest args)
571     (declare (ignore args))
572     (setf (stream-current-output-record stream) (stream-output-history stream)))
573    
574     (defmethod stream-add-output-record ((stream output-recording-stream) record)
575 adejneka 1.16 (add-output-record record (stream-current-output-record stream)))
576 rouanet 1.11
577     (defmethod stream-replay ((stream output-recording-stream) &optional region)
578     (replay (stream-output-history stream) stream region))
579    
580 moore 1.34 (defmacro with-output-recording-options ((stream
581     &key (record nil record-supplied-p)
582     (draw nil draw-supplied-p))
583     &body body)
584 adejneka 1.16 (declare (type symbol stream))
585     (when (eq stream 't)
586 rouanet 1.18 (setq stream '*standard-output*))
587 moore 1.34 (let ((continuation-name (gensym "WITH-OUTPUT-RECORDING-OPTIONS")))
588     `(flet ((,continuation-name (,stream) ,@body))
589 moore 1.36 (declare (dynamic-extent #',continuation-name))
590 adejneka 1.16 (invoke-with-output-recording-options ,stream
591 moore 1.34 #',continuation-name
592     ,(if record-supplied-p
593     record
594     `(stream-recording-p
595     ,stream))
596     ,(if draw-supplied-p
597     draw
598     `(stream-drawing-p
599     ,stream))))))
600    
601 adejneka 1.16
602     (defmethod invoke-with-output-recording-options
603     ((stream output-recording-stream) continuation record draw)
604     "Calls CONTINUATION on STREAM enabling or disabling recording and drawing
605     according to the flags RECORD and DRAW."
606 moore 1.34 (letf (((stream-recording-p stream) record)
607     ((stream-drawing-p stream) draw))
608     (funcall continuation stream)))
609 adejneka 1.16
610     (defmacro with-new-output-record ((stream
611     &optional
612 rouanet 1.18 (record-type 'standard-sequence-output-record)
613 adejneka 1.16 (record nil record-supplied-p)
614     &rest initargs)
615     &body body)
616     "Creates a new output record of type RECORD-TYPE and then captures
617     the output of BODY into the new output record, and inserts the new
618     record into the current \"open\" output record assotiated with STREAM.
619     If RECORD is supplied, it is the name of a variable that will be
620     lexically bound to the new output record inside the body. INITARGS are
621     CLOS initargs that are passed to MAKE-INSTANCE when the new output
622     record is created.
623     It returns the created output record.
624     The STREAM argument is a symbol that is bound to an output
625     recording stream. If it is T, *STANDARD-OUTPUT* is used."
626     (declare (type symbol stream record))
627     (when (eq stream 't)
628     (setq stream '*standard-output*))
629     (unless record-supplied-p
630     (setq record (gensym)))
631     `(invoke-with-new-output-record
632     ,stream
633     #'(lambda (,stream ,record)
634 adejneka 1.42 (declare (ignorable ,stream ,record))
635 adejneka 1.16 ,@body)
636 rouanet 1.18 ',record-type
637 adejneka 1.16 ,@initargs))
638    
639     (defmethod invoke-with-new-output-record ((stream output-recording-stream)
640     continuation record-type
641     &rest initargs
642 moore 1.31 &key parent
643     &allow-other-keys)
644 adejneka 1.20 (stream-close-text-output-record stream)
645 adejneka 1.16 (unless parent
646     (setq parent (stream-current-output-record stream)))
647 adejneka 1.22 (let ((new-record (apply #'make-instance record-type :parent parent initargs)))
648     (letf (((stream-current-output-record stream) new-record))
649 adejneka 1.43 ;; Should we switch on recording? -- APD
650 adejneka 1.22 (funcall continuation stream new-record)
651     (finish-output stream))
652     (stream-add-output-record stream new-record)
653 adejneka 1.16 new-record))
654 cvs 1.10
655 adejneka 1.43 (defmacro with-output-to-output-record
656     ((stream
657     &optional
658     (record-type 'standard-sequence-output-record)
659     (record nil record-supplied-p)
660     &rest initargs)
661     &body body)
662     "Creates a new output record of type RECORD-TYPE and then captures
663     the output of BODY into the new output record. The cursor position of
664     STREAM is initially bound to (0,0)
665     If RECORD is supplied, it is the name of a variable that will be
666     lexically bound to the new output record inside the body. INITARGS are
667     CLOS initargs that are passed to MAKE-INSTANCE when the new output
668     record is created.
669     It returns the created output record.
670     The STREAM argument is a symbol that is bound to an output
671     recording stream. If it is T, *STANDARD-OUTPUT* is used."
672     (when (eq stream 't)
673     (setq stream '*standard-output*))
674     (check-type stream symbol)
675     (unless record-supplied-p (setq record (gensym "RECORD")))
676     `(invoke-with-output-to-output-record
677     ,stream
678     #'(lambda (,stream ,record)
679     (declare (ignorable ,stream ,record))
680     ,@body)
681     ',record-type
682     ,@initargs))
683    
684     (defmethod invoke-with-output-to-output-record
685     ((stream output-recording-stream)
686     continuation record-type
687     &rest initargs
688     &key parent
689     &allow-other-keys)
690     (stream-close-text-output-record stream)
691     (unless parent (setq parent (stream-current-output-record stream)))
692     (let ((new-record (apply #'make-instance record-type
693     :parent parent initargs)))
694     (with-output-recording-options (stream :record t :draw nil)
695     (multiple-value-bind (cx cy)
696     (stream-cursor-position stream)
697     (unwind-protect
698     (letf (((stream-current-output-record stream) new-record))
699     (setf (stream-cursor-position stream) (values 0 0))
700     (funcall continuation stream new-record)
701     (finish-output stream))
702     (setf (stream-cursor-position stream) (values cx cy)))))
703     new-record))
704    
705 rouanet 1.11 (defmethod scroll-vertical :around ((stream output-recording-stream) dy)
706 mikemac 1.1 (declare (ignore dy))
707     (with-output-recording-options (stream :record nil)
708 mikemac 1.40 (declare (ignore stream))
709 mikemac 1.1 (call-next-method)))
710    
711 rouanet 1.11 (defmethod scroll-horizontal :around ((stream output-recording-stream) dx)
712 mikemac 1.1 (declare (ignore dx))
713     (with-output-recording-options (stream :record nil)
714 mikemac 1.40 (declare (ignore stream))
715 mikemac 1.1 (call-next-method)))
716    
717 gilbert 1.38 (defmethod handle-repaint ((stream output-recording-stream) region)
718 rouanet 1.11 (stream-replay stream region))
719 cvs 1.7
720 rouanet 1.11 #|
721     (defmethod handle-event :after ((stream output-recording-stream) (event pointer-button-press-event))
722 rouanet 1.18 (highlight-output-record (stream-current-output-record stream) stream :highlight))
723 rouanet 1.11
724     (defmethod handle-event :before ((stream output-recording-stream) (event pointer-button-release-event))
725 rouanet 1.18 (highlight-output-record (stream-current-output-record stream) stream :unhighlight))
726 rouanet 1.11 |#
727 mikemac 1.1
728    
729 adejneka 1.21 ;;; Graphics and text recording classes
730 mikemac 1.1
731 moore 1.34 (eval-when (:compile-toplevel :load-toplevel :execute)
732 adejneka 1.41
733 mikemac 1.1 (defun compute-class-vars (names)
734     (cons (list 'stream :initarg :stream)
735     (loop for name in names
736 adejneka 1.41 collecting (list name :initarg (intern (symbol-name name)
737     :keyword)))))
738 mikemac 1.1
739     (defun compute-arg-list (names)
740     (loop for name in names
741 cvs 1.2 nconcing (list (intern (symbol-name name) :keyword) name)))
742 mikemac 1.1 )
743    
744     (defmacro def-grecording (name (&rest args) &body body)
745     (let ((method-name (intern (format nil "MEDIUM-~A*" name)))
746     (class-name (intern (format nil "~A-OUTPUT-RECORD" name)))
747 adejneka 1.41 (medium (gensym "MEDIUM"))
748 adejneka 1.44 (border 'border))
749 cvs 1.10 `(progn
750 moore 1.34 (defclass ,class-name (graphics-displayed-output-record-mixin)
751 mikemac 1.1 ,(compute-class-vars args))
752     (defmethod initialize-instance :after ((graphic ,class-name) &rest args)
753     (declare (ignore args))
754 rouanet 1.18 (with-slots (x y x1 y1 x2 y2 initial-x1 initial-y1
755 adejneka 1.14 stream ink clipping-region transform
756 mikemac 1.1 line-style text-style
757     ,@args) graphic
758 adejneka 1.44 (let ((,border (/ (line-style-effective-thickness
759     line-style (sheet-medium stream))
760     2)))
761     (declare (ignorable ,border))
762     (multiple-value-setq (x1 y1 x2 y2) (progn ,@body)))
763 rouanet 1.18 (setf x x1
764     y y1
765     initial-x1 x1
766     initial-y1 y1)))
767 rouanet 1.11 (defmethod ,method-name :around ((stream output-recording-stream) ,@args)
768 mikemac 1.1 (with-sheet-medium (medium stream)
769 cvs 1.5 (when (stream-recording-p stream)
770     (let ((record (make-instance ',class-name
771     :stream stream
772     :ink (medium-ink medium)
773     :clipping-region (medium-clipping-region medium)
774     :transformation (medium-transformation medium)
775     :line-style (medium-line-style medium)
776     :text-style (medium-text-style medium)
777     ,@(compute-arg-list args))))
778 rouanet 1.11 (stream-add-output-record stream record)))
779 cvs 1.5 (when (stream-drawing-p stream)
780     (call-next-method))))
781 mikemac 1.1 (defmethod replay-output-record ((record ,class-name) stream
782 rouanet 1.18 &optional (region +everywhere+)
783     (x-offset 0) (y-offset 0))
784     (with-slots (x y initial-x1 initial-y1
785     ink clip transform line-style text-style ,@args) record
786     (let ((transformation (compose-translation-with-transformation
787     transform
788     (+ (- x initial-x1) x-offset)
789 adejneka 1.41 (+ (- y initial-y1) y-offset)))
790     (,medium (sheet-medium stream))
791     ;; is sheet a sheet-with-medium-mixin? --GB
792     )
793     (letf (((medium-ink ,medium) ink)
794     ((medium-transformation ,medium) transformation)
795     ((medium-clipping-region ,medium)
796     (region-intersection clip
797     (untransform-region transformation
798     region)))
799     ((medium-line-style ,medium) line-style)
800     ((medium-text-style ,medium) text-style))
801     (,method-name ,medium ,@args))))))))
802 mikemac 1.1
803 rouanet 1.11 (def-grecording draw-point (point-x point-y)
804 adejneka 1.14 (with-transformed-position (transform point-x point-y)
805 adejneka 1.44 (values (- point-x border)
806     (- point-y border)
807     (+ point-x border)
808     (+ point-y border))))
809 mikemac 1.1
810     (def-grecording draw-points (coord-seq)
811 adejneka 1.14 (with-transformed-positions (transform coord-seq)
812     (loop for (x y) on coord-seq by #'cddr
813     minimize x into min-x
814     minimize y into min-y
815     maximize x into max-x
816     maximize y into max-y
817 adejneka 1.44 finally (return (values (- min-x border)
818     (- min-y border)
819     (+ max-x border)
820     (+ max-y border))))))
821 mikemac 1.1
822 rouanet 1.11 (def-grecording draw-line (point-x1 point-y1 point-x2 point-y2)
823 adejneka 1.14 (with-transformed-position (transform point-x1 point-y1)
824     (with-transformed-position (transform point-x2 point-y2)
825 adejneka 1.44 (values (- (min point-x1 point-x2) border)
826     (- (min point-y1 point-y2) border)
827     (+ (max point-x1 point-x2) border)
828     (+ (max point-y1 point-y2) border)))))
829 mikemac 1.1
830     (def-grecording draw-lines (coord-seq)
831 adejneka 1.14 (with-transformed-positions (transform coord-seq)
832     (loop for (x y) on coord-seq by #'cddr
833     minimize x into min-x
834     minimize y into min-y
835     maximize x into max-x
836     maximize y into max-y
837 adejneka 1.44 finally (return (values (- min-x border)
838     (- min-y border)
839     (+ max-x border)
840     (+ max-y border))))))
841 mikemac 1.1
842     (def-grecording draw-polygon (coord-seq closed filled)
843 adejneka 1.16 ;; FIXME !!!
844     ;; If LINE-STYLE-JOINT-SHAPE is :MITTER, then the bb is larger than
845     ;; these numbers by (LINE-THICKNESS / (sin (angle / 2))),
846     ;; which is larger than LINE-THICKNESS
847 adejneka 1.14 (with-transformed-positions (transform coord-seq)
848     (loop for (x y) on coord-seq by #'cddr
849     minimize x into min-x
850     minimize y into min-y
851     maximize x into max-x
852     maximize y into max-y
853 adejneka 1.44 finally (return (if filled
854     (values min-x min-y max-x max-y)
855     (values (- min-x border)
856     (- min-y border)
857     (+ max-x border)
858     (+ max-y border)))))))
859 mikemac 1.1
860     (def-grecording draw-rectangle (left top right bottom filled)
861 adejneka 1.17 ;; FIXME!!! If the rectangle is a line/point, MAKE-RECTANGLE* gives +NOWHERE+,
862     ;; and BOUNDING-RECTANGLE* signals an error.
863 adejneka 1.44 (multiple-value-bind (min-x min-y max-x max-y)
864     (bounding-rectangle* (transform-region transform
865     (make-rectangle*
866     left top right bottom)))
867     (if filled
868     (values min-x min-y max-x max-y)
869     (values (- min-x border)
870     (- min-y border)
871     (+ max-x border)
872     (+ max-y border)))))
873 mikemac 1.1
874     (def-grecording draw-ellipse (center-x center-y
875     radius-1-dx radius-1-dy radius-2-dx radius-2-dy
876     start-angle end-angle filled)
877 adejneka 1.44 (multiple-value-bind (min-x min-y max-x max-y)
878     (bounding-rectangle*
879     (transform-region transform
880     (make-ellipse* center-x center-y
881     radius-1-dx radius-1-dy
882     radius-2-dx radius-2-dy
883     :start-angle start-angle
884     :end-angle end-angle)))
885     (if filled
886     (values min-x min-y max-x max-y)
887     (values (- min-x border)
888     (- min-y border)
889     (+ max-x border)
890     (+ max-y border)))))
891 rouanet 1.11
892     (def-grecording draw-text (string point-x point-y start end
893     align-x align-y toward-x toward-y transform-glyphs)
894 adejneka 1.44 ;; FIXME!!! Text direction.
895 adejneka 1.43 ;; Multiple lines?
896 rouanet 1.11 (let* ((width (stream-string-width stream string
897     :start start :end end
898     :text-style text-style))
899 strandh 1.26 (ascent (text-style-ascent text-style (sheet-medium stream)))
900     (descent (text-style-descent text-style (sheet-medium stream)))
901 rouanet 1.11 (height (+ ascent descent))
902     left top right bottom)
903     (ecase align-x
904     (:left (setq left point-x
905     right (+ point-x width)))
906     (:right (setq left (- point-x width)
907     right point-x))
908     (:center (setq left (- point-x (round width 2))
909     right (+ point-x (round width 2)))))
910     (ecase align-y
911 adejneka 1.43 (:baseline (setq top (- point-y ascent)
912 rouanet 1.11 bottom (+ point-y descent)))
913     (:top (setq top point-y
914     bottom (+ point-y height)))
915     (:bottom (setq top (- point-y height)
916     bottom point-y))
917     (:center (setq top (- point-y (floor height 2))
918     bottom (+ point-y (ceiling height 2)))))
919     (values left top right bottom)))
920 mikemac 1.1
921    
922     ;;; Text recording class
923    
924     (defclass text-displayed-output-record (displayed-output-record)
925 moore 1.34 ())
926    
927     (defclass text-displayed-output-record-mixin
928     (text-displayed-output-record displayed-output-record-mixin)
929 mikemac 1.1 ((strings :initform nil)
930     (baseline :initform 0)
931 adejneka 1.22 (width :initform 0)
932 mikemac 1.1 (max-height :initform 0)
933 cvs 1.6 (start-x :initarg :start-x)
934     (start-y :initarg :start-y)
935 mikemac 1.1 (end-x)
936 cvs 1.8 (end-y)
937     (wrapped :initform nil
938 adejneka 1.21 :accessor text-record-wrapped)))
939 mikemac 1.1
940     (defun text-displayed-output-record-p (x)
941     (typep x 'text-displayed-output-record))
942    
943 moore 1.34 (defmethod print-object ((self text-displayed-output-record-mixin) stream)
944 cvs 1.8 (print-unreadable-object (self stream :type t :identity t)
945     (if (slot-boundp self 'start-x)
946     (with-slots (start-x start-y strings) self
947     (format stream "~D,~D ~S" start-x start-y (mapcar #'third strings)))
948     (format stream "empty"))))
949 mikemac 1.1
950 adejneka 1.21 (defgeneric add-character-output-to-text-record
951     (text-record character text-style width height baseline))
952     (defgeneric add-string-output-to-text-record
953     (text-record string start end text-style width height baseline))
954     (defgeneric text-displayed-output-record-string (text-record))
955    
956     ;;; Methods
957 moore 1.34 (defmethod tree-recompute-extent
958     ((text-record text-displayed-output-record-mixin))
959 adejneka 1.22 (with-slots (parent x y
960     x1 y1 x2 y2 width max-height) text-record
961     (setq x1 (coordinate x)
962     y1 (coordinate y)
963     x2 (coordinate (+ x width))
964     y2 (coordinate (+ y max-height)))))
965    
966 moore 1.34 (defmethod* (setf output-record-position) :before
967     (nx ny (record text-displayed-output-record-mixin))
968 adejneka 1.22 (with-slots (x1 y1 x2 y2 x y start-x start-y end-x end-y) record
969 rouanet 1.23 (let ((dx (- nx x))
970     (dy (- ny y)))
971     (incf start-x dx)
972     (incf start-y dy)
973     (incf end-x dx)
974     (incf end-y dy))))
975 cvs 1.9
976 moore 1.34 (defmethod add-character-output-to-text-record ((text-record text-displayed-output-record-mixin)
977 adejneka 1.22 character text-style char-width height
978 mikemac 1.1 new-baseline)
979 adejneka 1.22 (with-slots (strings baseline width max-height start-y end-x end-y) text-record
980 cvs 1.7 (if (and strings (eq (second (first (last strings))) text-style))
981     (vector-push-extend character (third (first (last strings))))
982     (setq strings (nconc strings (list (list end-x text-style (make-array 1 :initial-element character :element-type 'character :adjustable t :fill-pointer t))))))
983     (setq baseline (max baseline new-baseline)
984 adejneka 1.22 end-x (+ end-x char-width)
985 mikemac 1.1 max-height (max max-height height)
986 cvs 1.9 end-y (max end-y (+ start-y max-height))
987 adejneka 1.22 width (+ width char-width)))
988 cvs 1.9 (tree-recompute-extent text-record))
989 mikemac 1.1
990 moore 1.34 (defmethod add-string-output-to-text-record ((text-record text-displayed-output-record-mixin)
991 adejneka 1.22 string start end text-style string-width height
992 mikemac 1.1 new-baseline)
993 adejneka 1.20 (if end
994 adejneka 1.21 (setq end (min end (1- (length string))))
995 adejneka 1.20 (setq end (1- (length string))))
996     (let ((length (max 0 (- (1+ end) start))))
997 mikemac 1.28 (cond
998     ((= length 1)
999     (add-character-output-to-text-record text-record (aref string start) text-style string-width height new-baseline))
1000     (t
1001     (setq string (make-array length :displaced-to string
1002     :displaced-index-offset start
1003     :element-type (array-element-type string)))
1004     (with-slots (strings baseline width max-height start-y end-x end-y) text-record
1005     (setq baseline (max baseline new-baseline)
1006     strings (nconc strings
1007     (list (list end-x text-style
1008     (make-array (length string)
1009     :initial-contents string
1010     :element-type 'character
1011     :adjustable t
1012     :fill-pointer t))))
1013     end-x (+ end-x string-width)
1014     max-height (max max-height height)
1015     end-y (max end-y (+ start-y max-height))
1016     width (+ width string-width)))
1017     (tree-recompute-extent text-record)))))
1018 mikemac 1.1
1019 moore 1.34 (defmethod replay-output-record ((record text-displayed-output-record-mixin)
1020     stream
1021 adejneka 1.21 &optional region (x-offset 0) (y-offset 0))
1022 mikemac 1.30 (declare (ignore region))
1023 adejneka 1.20 (with-slots (strings baseline max-height start-x start-y wrapped
1024 adejneka 1.21 x y x1 y1 initial-x1 initial-y1) record
1025 cvs 1.7 (let ((old-medium (sheet-medium stream))
1026     (new-medium (make-medium (port stream) stream)))
1027     (unwind-protect
1028 adejneka 1.22 (progn
1029 gilbert 1.33 (setf (%sheet-medium stream) new-medium) ;is sheet a sheet-with-medium-mixin? --GB
1030     (setf (%medium-sheet new-medium) stream) ;is medium a basic medium?
1031 adejneka 1.22 (setf (medium-transformation new-medium)
1032 adejneka 1.20 (make-translation-transformation
1033 adejneka 1.22 x-offset
1034     y-offset))
1035 adejneka 1.41
1036 rouanet 1.23 (setf (stream-cursor-position stream) (values start-x start-y))
1037 adejneka 1.22 (letf (((slot-value stream 'baseline) baseline))
1038     (loop for (x text-style string) in strings
1039     do (setf (medium-text-style new-medium) text-style)
1040 mikemac 1.28 (setf (stream-cursor-position stream)
1041     (values (+ x (- x1 initial-x1)) start-y))
1042     (stream-write-line stream string)))
1043 adejneka 1.22 ;; clipping region
1044     #|restore cursor position? set to (end-x,end-y)?|#
1045     #+nil(loop for y = (+ start-y baseline)
1046     for (x text-style string) in strings
1047     do (setf (medium-text-style new-medium) text-style)
1048     (draw-text* (sheet-medium stream) string x y
1049     :text-style text-style :clipping-region (untransform-region (medium-transformation new-medium) region)))
1050     (if wrapped
1051     (draw-rectangle* (sheet-medium stream)
1052     (+ wrapped 0) start-y (+ wrapped 4) (+ start-y max-height)
1053     :ink +foreground-ink+
1054     :filled t)))
1055 gilbert 1.33 (setf (%sheet-medium stream) old-medium))))) ;is sheet a sheet-with-medium-mixin? --GB
1056 mikemac 1.1
1057 moore 1.34 (defmethod output-record-start-cursor-position
1058     ((record text-displayed-output-record-mixin))
1059 mikemac 1.1 (with-slots (start-x start-y) record
1060     (values start-x start-y)))
1061    
1062 moore 1.34 (defmethod output-record-end-cursor-position
1063     ((record text-displayed-output-record-mixin))
1064 mikemac 1.1 (with-slots (end-x end-y) record
1065     (values end-x end-y)))
1066    
1067 moore 1.34 (defmethod text-displayed-output-record-string
1068     ((record text-displayed-output-record-mixin))
1069 mikemac 1.1 (with-slots (strings) record
1070     (loop for result = ""
1071     for s in strings
1072     do (setq result (concatenate 'string result (third s)))
1073     finally (return result))))
1074 cvs 1.5
1075    
1076 moore 1.34 (defclass stream-text-record (text-displayed-output-record-mixin)
1077     ())
1078    
1079 adejneka 1.21 ;;; Methods for text output to output recording streams
1080 adejneka 1.22 (defmethod stream-text-output-record ((stream standard-output-recording-stream) text-style)
1081 mikemac 1.30 (declare (ignore text-style))
1082 adejneka 1.20 (let ((record (stream-current-text-output-record stream)))
1083     (unless record
1084     (setf (stream-current-text-output-record stream)
1085 moore 1.34 (setq record (make-instance 'stream-text-record)))
1086 adejneka 1.22 (with-slots (start-x start-y end-x end-y x1 y1 x2 y2 x y
1087 adejneka 1.20 initial-x1 initial-y1) record
1088 cvs 1.8 (multiple-value-bind (cx cy) (stream-cursor-position stream)
1089 adejneka 1.22 (setq start-x cx
1090     start-y cy
1091 cvs 1.8 end-x start-x
1092 cvs 1.9 end-y start-y
1093 adejneka 1.22 x1 (coordinate start-x)
1094     x2 (coordinate end-x)
1095     y1 (coordinate start-y)
1096     y2 (coordinate end-y)
1097 adejneka 1.20 initial-x1 x1
1098 adejneka 1.22 initial-y1 y1
1099     x start-x
1100     y start-y))))
1101 adejneka 1.20 record))
1102    
1103 adejneka 1.22 (defmethod stream-close-text-output-record ((stream standard-output-recording-stream))
1104 adejneka 1.20 (let ((record (stream-current-text-output-record stream)))
1105     (when record
1106     (setf (stream-current-text-output-record stream) nil)
1107     #|record stream-current-cursor-position to (end-x record) - already done|#
1108     (stream-add-output-record stream record))))
1109    
1110 adejneka 1.22 (defmethod stream-add-character-output ((stream standard-output-recording-stream)
1111 adejneka 1.20 character text-style
1112     width height baseline)
1113     (add-character-output-to-text-record (stream-text-output-record stream text-style)
1114     character text-style width height baseline))
1115    
1116 adejneka 1.22 (defmethod stream-add-string-output ((stream standard-output-recording-stream)
1117 adejneka 1.20 string start end text-style
1118     width height baseline)
1119     (add-string-output-to-text-record (stream-text-output-record stream text-style)
1120     string start end text-style
1121     width height baseline))
1122    
1123     (defmacro without-local-recording (stream &body body)
1124 adejneka 1.22 `(letf (((slot-value ,stream 'local-record-p) nil))
1125     ,@body))
1126    
1127     (defmethod stream-write-line :around ((stream standard-output-recording-stream) line)
1128     (when (and (stream-recording-p stream)
1129     (slot-value stream 'local-record-p))
1130     (let* ((medium (sheet-medium stream))
1131 strandh 1.26 (text-style (medium-text-style medium)))
1132 adejneka 1.22 (stream-add-string-output stream line 0 nil text-style
1133     (stream-string-width stream line
1134     :text-style text-style)
1135 strandh 1.26 (text-style-height text-style medium)
1136     (text-style-ascent text-style medium))))
1137 adejneka 1.22 (when (stream-drawing-p stream)
1138     (without-local-recording stream
1139     (call-next-method))))
1140 cvs 1.5
1141 adejneka 1.22 #+nil
1142     (defmethod stream-write-char :around ((stream standard-output-recording-stream) char)
1143 adejneka 1.20 (when (and (stream-recording-p stream)
1144     (slot-value stream 'local-record-p))
1145     (if (or (eql char #\return)
1146     (eql char #\newline))
1147     (stream-close-text-output-record stream)
1148 cvs 1.8 (let* ((medium (sheet-medium stream))
1149 strandh 1.26 (text-style (medium-text-style medium)))
1150 adejneka 1.20 (stream-add-character-output stream char text-style
1151     (stream-character-width stream char :text-style text-style)
1152 strandh 1.26 (text-style-height text-style medium)
1153     (text-style-ascent text-style medium)))))
1154 adejneka 1.20 (without-local-recording stream
1155     (call-next-method)))
1156    
1157 adejneka 1.21 #+nil
1158 adejneka 1.22 (defmethod stream-write-string :around ((stream standard-output-recording-stream) string
1159 adejneka 1.20 &optional (start 0) end)
1160 adejneka 1.21 ;; Problem: it is necessary to check for line wrapping. Now the
1161     ;; default method for STREAM-WRITE-STRING do char-by-char output,
1162     ;; therefore STREAM-WRITE-CHAR can do the right thing.
1163 adejneka 1.20 (when (and (stream-recording-p stream)
1164     (slot-value stream 'local-record-p))
1165     (let* ((medium (sheet-medium stream))
1166 strandh 1.26 (text-style (medium-text-style medium)))
1167 adejneka 1.20 (stream-add-string-output stream string start end text-style
1168     (stream-string-width stream string
1169     :start start :end end
1170     :text-style text-style)
1171 strandh 1.26 (text-style-height text-style medium)
1172     (text-style-ascent text-style medium))))
1173 adejneka 1.20 (without-local-recording stream
1174     (call-next-method)))
1175 adejneka 1.41
1176 adejneka 1.20
1177 adejneka 1.22 (defmethod stream-finish-output :after ((stream standard-output-recording-stream))
1178 adejneka 1.20 (stream-close-text-output-record stream))
1179    
1180 adejneka 1.22 (defmethod stream-force-output :after ((stream standard-output-recording-stream))
1181 adejneka 1.20 (stream-close-text-output-record stream))
1182    
1183 adejneka 1.22 (defmethod stream-terpri :after ((stream standard-output-recording-stream))
1184 adejneka 1.21 (stream-close-text-output-record stream))
1185    
1186 rouanet 1.23 (defmethod* (setf stream-cursor-position) :after (x y (stream standard-output-recording-stream))
1187 mikemac 1.30 (declare (ignore x y))
1188 adejneka 1.20 (stream-close-text-output-record stream))
1189    
1190 adejneka 1.22 ;(defmethod stream-set-cursor-position :after ((stream standard-output-recording-stream))
1191 adejneka 1.20 ; (stream-close-text-output-record stream))
1192 cvs 1.5
1193 adejneka 1.22 (defmethod stream-wrap-line :before ((stream standard-output-recording-stream))
1194 cvs 1.5 (when (stream-recording-p stream)
1195 adejneka 1.20 (setf (text-record-wrapped (stream-text-output-record stream nil)) ; FIXME!
1196     (stream-text-margin stream))))

  ViewVC Help
Powered by ViewVC 1.1.5