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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.35 - (hide annotations)
Fri Apr 19 22:27:09 2002 UTC (12 years ago) by moore
Branch: MAIN
Changes since 1.34: +41 -13 lines
Make a global choice, based on multiprocessing or not, whether events
should be handled immediately or queued up to be serviced by another
process.  The choice is implemented by the classes
clim-sheet-input-mixin and clim-repainting-mixin, from which all panes
inherit.  These classes' superclasses are conditionalized on whether or
not the implementation is capable of multiprocessing.

When multiprocessing there is a single event queue per frame.  This is
implemented by queue-event on pane classes.

The event loop is implemented in stream-input-wait.  In single
processing mode, stream-input-wait calls process-next-event and
handles events immediately.  When multiprocessing, stream-input-wait
reads events from the frame event queue and handles them.  The
function clim-extensions:simple-event-loop is supplied for
applications which do not loop reading from a stream; various examples
have been changed to use it.

In stream-read-gesture/stream-input-wait the input-wait-test function
is not expected to block anymore; nor is the input-wait-handler
expected to dispatch events.  input-wait-handler is responsible for
consuming events that should not be seen by anyone
else. input-context-wait-test and highlight-applicable-presentation
have been rewritten to reflect this.

The adjustable-array buffer for extended-input-streams has been added
back in.  A typo in %event-matches-gesture has been fixed.

Default methods for map-over-output-records-containing-position and
map-over-output-records-overlapping-region have been added.

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

  ViewVC Help
Powered by ViewVC 1.1.5