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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5