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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.62 - (hide annotations)
Fri Mar 21 21:36:59 2003 UTC (11 years, 1 month ago) by mikemac
Branch: MAIN
Changes since 1.61: +1 -1 lines
make all of the package names passed to in-package be lowercase keywords for ACL's java mode
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 adejneka 1.47 ;;;
28     ;;; - Scrolling does not work correctly. Region is given in "window"
29     ;;; coordinates, without bounding-rectangle-position transformation.
30 adejneka 1.51 ;;; (Is it still valid?)
31 adejneka 1.47 ;;;
32 adejneka 1.21 ;;; - Redo setf*-output-record-position, extent recomputation for
33 adejneka 1.47 ;;; compound records
34     ;;;
35 adejneka 1.41 ;;; - When DRAWING-P is NIL, should stream cursor move?
36 adejneka 1.47 ;;;
37     ;;; - :{X,Y}-OFFSET.
38 adejneka 1.49 ;;;
39     ;;; - (SETF OUTPUT-RECORD-START-CURSOR-POSITION) does not affect the
40     ;;; bounding rectangle. What does it affect?
41     ;;;
42 adejneka 1.51 ;;; - How should (SETF OUTPUT-RECORD-POSITION) affect the bounding
43     ;;; rectangle of the parent? Now its bounding rectangle is accurately
44     ;;; recomputed, but it is very inefficient for table formatting. It
45     ;;; seems that CLIM is supposed to keep a "large enougn" rectangle and
46     ;;; to shrink it to the correct size only when the layout is complete
47     ;;; by calling TREE-RECOMPUTE-EXTENT.
48     ;;;
49 adejneka 1.53 ;;; - Computation of the bounding rectangle of lines/polygons ignores
50 adejneka 1.51 ;;; LINE-STYLE-CAP-SHAPE.
51 adejneka 1.52 ;;;
52     ;;; - Rounding of coordinates.
53     ;;;
54     ;;; - Document carefully the interface of
55     ;;; STANDARD-OUTPUT-RECORDING-STREAM.
56 adejneka 1.53 ;;;
57     ;;; - COORD-SEQ is a sequence, not a list.
58 adejneka 1.46
59 adejneka 1.47 ;;; Troubles
60    
61     ;;; DC
62     ;;;
63     ;;; Some GFs are defined to have "a default method on CLIM's standard
64     ;;; output record class". What does it mean? What is "CLIM's standard
65     ;;; output record class"? Is it OUTPUT-RECORD or BASIC-OUTPUT-RECORD?
66     ;;; Now they are defined on OUTPUT-RECORD.
67    
68     ;;; TDO
69     ;;;
70     ;;; Text output record must save ink and clipping region. But its
71     ;;; protocol does not give any way to do it! And a user can put in a
72     ;;; history a record of any class :(. Now we are using
73     ;;; *DRAWING-OPTIONS* to put the necessary information and make sure
74     ;;; that only instances of STANDARD-TEXT-OUTPUT-RECORD are used for
75     ;;; recording. -- APD, 2002-06-15.
76 adejneka 1.22
77 mikemac 1.62 (in-package :clim-internals)
78 mikemac 1.1
79 adejneka 1.46 (define-protocol-class output-record (bounding-rectangle)
80 moore 1.34 ())
81    
82 adejneka 1.46 (define-protocol-class displayed-output-record (output-record)
83 moore 1.34 ())
84 mikemac 1.1
85 adejneka 1.46 ;;; 16.2.1. The Basic Output Record Protocol
86 mikemac 1.30 #+:cmu(declaim (ftype (function (output-record) (values rational rational))
87     output-record-position))
88 adejneka 1.22 (defgeneric output-record-position (record)
89     (:documentation
90     "Returns the x and y position of RECORD. The position is the
91     position of the upper-left corner of its bounding rectangle. The
92     position is relative to the stream, where (0,0) is (initially) the
93     upper-left corner of the stream."))
94    
95 adejneka 1.49 (defgeneric* (setf output-record-position) (x y record)
96     (:documentation
97     "Changes the x and y position of the RECORD to be X and Y, and
98     updates the bounding rectangle to reflect the new position (and saved
99     cursor positions, if the output record stores it). If RECORD has any
100     children, all of the children (and their descendants as well) will be
101     moved by the same amount as RECORD was moved. The bounding rectangles
102     of all of RECORD's ancestors will also be updated to be large enough
103     to contain 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 adejneka 1.46 "Returns the output record that is the parent of RECORD, or NIL if
128 adejneka 1.22 RECORD has no parent."))
129    
130 adejneka 1.47 (defgeneric (setf output-record-parent) (parent record)
131     (:documentation "Non-standard function."))
132    
133 adejneka 1.21 (defgeneric replay-output-record (record stream
134 adejneka 1.22 &optional region x-offset y-offset)
135     (:documentation "Displays the output captured by RECORD on the
136     STREAM, exactly as it was originally captured. The current user
137     transformation, line style, text style, ink and clipping region of
138     STREAM are all ignored. Instead, these are gotten from the output
139     record.
140    
141     Only those records that overlap REGION are displayed."))
142    
143 adejneka 1.21 (defgeneric output-record-hit-detection-rectangle* (record))
144 adejneka 1.22
145 adejneka 1.21 (defgeneric output-record-refined-position-test (record x y))
146 adejneka 1.22
147 adejneka 1.21 (defgeneric highlight-output-record (record stream state))
148 adejneka 1.22
149 adejneka 1.21 (defgeneric displayed-output-record-ink (displayed-output-record))
150    
151 adejneka 1.46 ;;; 16.2.2. Output Record "Database" Protocol
152 adejneka 1.22
153 adejneka 1.21 (defgeneric output-record-children (record))
154 adejneka 1.22
155 adejneka 1.21 (defgeneric add-output-record (child record))
156 adejneka 1.22
157 adejneka 1.46 (defgeneric delete-output-record (child record &optional errorp))
158 adejneka 1.22
159 adejneka 1.21 (defgeneric clear-output-record (record))
160 adejneka 1.22
161 adejneka 1.21 (defgeneric output-record-count (record))
162 adejneka 1.22
163 adejneka 1.21 (defgeneric map-over-output-records-containing-position
164 adejneka 1.46 (function record x y &optional x-offset y-offset &rest function-args)
165     (:documentation "Maps over all of the children of RECORD that
166     contain the point at (X,Y), calling FUNCTION on each one. FUNCTION is
167     a function of one or more arguments, the first argument being the
168     record containing the point. FUNCTION is also called with all of
169     FUNCTION-ARGS as APPLY arguments.
170    
171     If there are multiple records that contain the point,
172     MAP-OVER-OUTPUT-RECORDS-CONTAINING-POSITION hits the most recently
173     inserted record first and the least recently inserted record
174     last. Otherwise, the order in which the records are traversed is
175     unspecified."))
176 adejneka 1.22
177 adejneka 1.21 (defgeneric map-over-output-records-overlapping-region
178 adejneka 1.46 (function record region &optional x-offset y-offset &rest function-args)
179     (:documentation "Maps over all of the children of the RECORD that
180     overlap the REGION, calling FUNCTION on each one. FUNCTION is a
181     function of one or more arguments, the first argument being the record
182     overlapping the region. FUNCTION is also called with all of
183     FUNCTION-ARGS as APPLY arguments.
184    
185     If there are multiple records that overlap the region and that overlap
186     each other, MAP-OVER-OUTPUT-RECORDS-OVERLAPPING-REGION hits the least
187     recently inserted record first and the most recently inserted record
188     last. Otherwise, the order in which the records are traversed is
189     unspecified. "))
190 adejneka 1.21
191 moore 1.34 ;;; From the Franz CLIM user's guide but not in the spec... clearly necessary.
192 adejneka 1.46 ;;; What is its status? -- APD, 2002-06-14.
193 moore 1.34 (defgeneric map-over-output-records
194     (continuation record &optional x-offset y-offset &rest continuation-args))
195    
196 adejneka 1.46 ;;; 16.2.3. Output Record Change Notification Protocol
197 adejneka 1.22
198 adejneka 1.21 (defgeneric recompute-extent-for-new-child (record child))
199 adejneka 1.22
200 adejneka 1.21 (defgeneric recompute-extent-for-changed-child
201     (record child old-min-x old-min-y old-max-x old-max-y))
202 adejneka 1.22
203 adejneka 1.21 (defgeneric tree-recompute-extent (record))
204    
205 adejneka 1.46 ;;; 16.3. Types of Output Records
206 moore 1.57 (define-protocol-class graphics-displayed-output-record
207     (displayed-output-record)
208 adejneka 1.46 ())
209 adejneka 1.22
210 adejneka 1.46 (define-protocol-class text-displayed-output-record (displayed-output-record)
211     ())
212    
213     ;;; 16.3.3. Text Displayed Output Record
214     (defgeneric add-character-output-to-text-record
215     (text-record character text-style width height baseline))
216    
217     (defgeneric add-string-output-to-text-record
218     (text-record string start end text-style width height baseline))
219    
220     (defgeneric text-displayed-output-record-string (text-record))
221    
222     ;;; 16.4. Output Recording Streams
223     (define-protocol-class output-recording-stream ()
224     ())
225    
226     ;;; 16.4.1. The Output Recording Stream Protocol
227     (defgeneric stream-recording-p (stream))
228    
229     (defgeneric (setf stream-recording-p) (recording-p stream))
230    
231     (defgeneric stream-drawing-p (stream))
232    
233     (defgeneric (setf stream-drawing-p) (drawing-p stream))
234    
235     (defgeneric stream-output-history (stream))
236 moore 1.34
237 adejneka 1.46 (defgeneric stream-current-output-record (stream))
238    
239     (defgeneric (setf stream-current-output-record) (record stream))
240    
241     (defgeneric stream-add-output-record (stream record))
242    
243     (defgeneric stream-replay (stream &optional region))
244    
245     (defgeneric erase-output-record (record stream &optional errorp))
246    
247     ;;; 16.4.3. Text Output Recording
248     (defgeneric stream-text-output-record (stream text-style))
249    
250     (defgeneric stream-close-text-output-record (stream))
251    
252     (defgeneric stream-add-character-output
253     (stream character text-style width height baseline))
254    
255     (defgeneric stream-add-string-output
256     (stream string start end text-style width height baseline))
257    
258     ;;; 16.4.4. Output Recording Utilities
259     (defgeneric invoke-with-output-recording-options
260     (stream continuation record draw))
261    
262     (defgeneric invoke-with-new-output-record (stream continuation record-type
263     &rest initargs
264 adejneka 1.50 &key
265 adejneka 1.46 &allow-other-keys))
266    
267     (defgeneric invoke-with-output-to-output-record
268     (stream continuation record-type
269     &rest initargs
270 adejneka 1.50 &key
271 adejneka 1.46 &allow-other-keys))
272    
273     (defgeneric make-design-from-output-record (record))
274    
275 moore 1.57 ;;; 21.3 Incremental Redisplay Protocol. These generic functions need
276     ;;; to be implemented for all the basic displayed-output-records, so they are
277     ;;; defined in this file.
278    
279     (defgeneric match-output-records (record &rest args))
280    
281     (defgeneric match-output-records-1 (record &key)
282     (:method-combination and :most-specific-last))
283    
284 adejneka 1.49 ;;; Macros
285     (defmacro with-output-recording-options ((stream
286     &key (record nil record-supplied-p)
287     (draw nil draw-supplied-p))
288     &body body)
289     (when (eq stream 't) (setq stream '*standard-output*))
290     (check-type stream symbol)
291     (with-gensyms (continuation)
292 moore 1.57 `(flet ((,continuation (,stream)
293     (declare (ignorable ,stream))
294     ,@body))
295 adejneka 1.49 (declare (dynamic-extent #',continuation))
296     (invoke-with-output-recording-options
297     ,stream #',continuation
298     ,(if record-supplied-p record `(stream-recording-p ,stream))
299     ,(if draw-supplied-p draw `(stream-drawing-p ,stream))))))
300    
301     (defmacro with-new-output-record ((stream
302     &optional
303     (record-type ''standard-sequence-output-record)
304     (record nil record-supplied-p)
305     &rest initargs)
306     &body body)
307     "Creates a new output record of type RECORD-TYPE and then captures
308     the output of BODY into the new output record, and inserts the new
309     record into the current \"open\" output record assotiated with STREAM.
310     If RECORD is supplied, it is the name of a variable that will be
311     lexically bound to the new output record inside the body. INITARGS are
312     CLOS initargs that are passed to MAKE-INSTANCE when the new output
313     record is created.
314     It returns the created output record.
315     The STREAM argument is a symbol that is bound to an output
316     recording stream. If it is T, *STANDARD-OUTPUT* is used."
317     (when (eq stream 't) (setq stream '*standard-output*))
318     (check-type stream symbol)
319     (unless record-supplied-p (setq record (gensym)))
320     `(invoke-with-new-output-record ,stream
321     #'(lambda (,stream ,record)
322     (declare (ignorable ,stream ,record))
323     ,@body)
324     ,record-type
325     ,@initargs))
326    
327     (defmacro with-output-to-output-record
328     ((stream
329     &optional (record-type ''standard-sequence-output-record)
330     (record nil record-supplied-p)
331     &rest initargs)
332     &body body)
333     "Creates a new output record of type RECORD-TYPE and then captures
334     the output of BODY into the new output record. The cursor position of
335     STREAM is initially bound to (0,0)
336     If RECORD is supplied, it is the name of a variable that will be
337     lexically bound to the new output record inside the body. INITARGS are
338     CLOS initargs that are passed to MAKE-INSTANCE when the new output
339     record is created.
340     It returns the created output record.
341     The STREAM argument is a symbol that is bound to an output
342     recording stream. If it is T, *STANDARD-OUTPUT* is used."
343     (when (eq stream 't) (setq stream '*standard-output*))
344     (check-type stream symbol)
345     (unless record-supplied-p (setq record (gensym "RECORD")))
346     `(invoke-with-output-to-output-record
347     ,stream
348     #'(lambda (,stream ,record)
349     (declare (ignorable ,stream ,record))
350     ,@body)
351     ,record-type
352     ,@initargs))
353    
354 adejneka 1.46
355     ;;;; Implementation
356    
357     (defclass basic-output-record (standard-bounding-rectangle output-record)
358 adejneka 1.47 ((parent :initarg :parent ; XXX
359 adejneka 1.46 :initform nil
360 adejneka 1.47 :accessor output-record-parent)) ; XXX
361 adejneka 1.46 (:documentation "Implementation class for the Basic Output Record Protocol."))
362    
363     (defmethod initialize-instance :after ((record basic-output-record)
364 adejneka 1.50 &rest args
365     &key (x-position 0) (y-position 0))
366 adejneka 1.46 (declare (ignore args))
367     (with-slots (x1 y1 x2 y2) record
368     (setq x1 x-position
369     y1 y-position
370     x2 x-position
371     y2 y-position)))
372    
373     (defclass compound-output-record (basic-output-record)
374     ((x :initarg :x-position
375     :initform 0
376     :documentation "X-position of the empty record.")
377     (y :initarg :y-position
378     :initform 0
379     :documentation "Y-position of the empty record.")
380     (in-moving-p :initform nil
381     :documentation "Is set while changing the position."))
382     (:documentation "Implementation class for output records with children."))
383    
384     ;;; 16.2.1. The Basic Output Record Protocol
385     (defmethod output-record-position ((record basic-output-record))
386     (bounding-rectangle-position record))
387 mikemac 1.1
388 adejneka 1.46 (defmethod* (setf output-record-position) (nx ny (record basic-output-record))
389     (with-slots (x1 y1 x2 y2) record
390     (let ((dx (- nx x1))
391     (dy (- ny y1)))
392     (setf x1 nx y1 ny
393 adejneka 1.47 x2 (+ x2 dx) y2 (+ y2 dy))))
394 moore 1.57 (values nx ny))
395 rouanet 1.11
396 moore 1.34 (defmethod* (setf output-record-position) :around
397     (nx ny (record basic-output-record))
398 adejneka 1.46 (with-bounding-rectangle* (min-x min-y max-x max-y) record
399     (call-next-method)
400     (let ((parent (output-record-parent record)))
401     (when parent
402     (recompute-extent-for-changed-child parent record
403 adejneka 1.47 min-x min-y max-x max-y))))
404 moore 1.57 (values nx ny))
405 moore 1.34
406 adejneka 1.46 (defmethod* (setf output-record-position) :before
407     (nx ny (record compound-output-record))
408     (with-slots (x1 y1 in-moving-p) record
409     (letf ((in-moving-p t))
410     (let ((dx (- nx x1))
411     (dy (- ny y1)))
412     (map-over-output-records
413     (lambda (child)
414     (multiple-value-bind (x y) (output-record-position child)
415     (setf (output-record-position child)
416     (values (+ x dx) (+ y dy)))))
417     record)))))
418 rouanet 1.11
419 moore 1.34 (defmethod output-record-start-cursor-position ((record basic-output-record))
420 mikemac 1.1 (values nil nil))
421    
422 moore 1.34 (defmethod* (setf output-record-start-cursor-position)
423     (x y (record basic-output-record))
424 moore 1.57 (values x y))
425 mikemac 1.1
426 moore 1.34 (defmethod output-record-end-cursor-position ((record basic-output-record))
427 mikemac 1.1 (values nil nil))
428    
429 moore 1.34 (defmethod* (setf output-record-end-cursor-position)
430     (x y (record basic-output-record))
431 moore 1.57 (values x y))
432    
433 mikemac 1.61 #+cmu
434 gilbert 1.60 (progn
435     ;; Sometimes CMU's PCL fails with forward reference classes, so this
436     ;; is a kludge to keep it happy.
437     ;;
438     ;; This was reported as a bug to cmucl-imp [<E18vKN1-0004DQ-00@saphir.local>]
439     ;;
440     ;; In short it exposes itself when you compile and load into a
441     ;; _virgin_ lisp the following:
442     ;;
443     ;; (defclass foo (bar) ())
444     ;; (defun barz () (make-instance 'foo))
445     ;; (defclass bar () ())
446     ;;
447     ;; --GB 2003-03-18
448     ;;
449     (defclass gs-ink-mixin () ())
450     (defclass gs-clip-mixin () ())
451     (defclass gs-line-style-mixin () ())
452     (defclass gs-text-style-mixin () ()))
453    
454 moore 1.57 ;;; Humph. It'd be nice to tie this to the actual definition of a
455     ;;; medium. -- moore
456     (defclass complete-medium-state
457     (gs-ink-mixin gs-clip-mixin gs-line-style-mixin gs-text-style-mixin)
458     ())
459 mikemac 1.1
460 adejneka 1.24 (defun replay (record stream &optional region)
461 adejneka 1.21 (stream-close-text-output-record stream)
462 rouanet 1.11 (when (stream-drawing-p stream)
463 adejneka 1.22 (with-cursor-off stream
464 adejneka 1.48 (letf (((stream-cursor-position stream) (values 0 0))
465 moore 1.57 ((stream-recording-p stream) nil)
466     ;; Is there a better value to bind to baseline?
467     ((slot-value stream 'baseline) (slot-value stream 'baseline)))
468     (with-sheet-medium (medium stream)
469     (let ((medium-state (make-instance 'complete-medium-state
470     :medium medium)))
471     (unwind-protect
472     (progn
473     (setf (medium-transformation medium)
474     +identity-transformation+)
475     (replay-output-record record stream region))
476     (set-medium-graphics-state medium-state medium))))))))
477    
478 mikemac 1.1
479 adejneka 1.46 (defmethod replay-output-record ((record compound-output-record) stream
480 rouanet 1.18 &optional region (x-offset 0) (y-offset 0))
481 rouanet 1.11 (when (null region)
482 gilbert 1.59 (let ((viewport (pane-viewport stream)))
483     (cond ((not (null viewport))
484     (setf region (untransform-region (sheet-delta-transformation stream viewport)
485     (pane-viewport-region stream))))
486     (t
487     (setq region +everywhere+)))))
488     (with-drawing-options (stream :clipping-region region)
489     (map-over-output-records-overlapping-region
490     #'replay-output-record record region x-offset y-offset
491     stream region x-offset y-offset)))
492 mikemac 1.1
493 adejneka 1.46 (defmethod output-record-hit-detection-rectangle* ((record output-record))
494     ;; XXX DC
495 mikemac 1.1 (bounding-rectangle* record))
496    
497 moore 1.39 (defmethod output-record-refined-position-test ((record basic-output-record)
498     x y)
499 rouanet 1.13 (declare (ignore x y))
500     t)
501 mikemac 1.1
502 moore 1.34 ;;; XXX Should this only be defined on recording streams?
503 adejneka 1.46 (defmethod highlight-output-record ((record output-record)
504 moore 1.34 stream state)
505 adejneka 1.46 ;; XXX DC
506     ;; XXX Disable recording?
507     (letf (((medium-transformation stream) +identity-transformation+))
508     (multiple-value-bind (x1 y1 x2 y2)
509     (output-record-hit-detection-rectangle* record)
510     (ecase state
511     (:highlight
512     (draw-rectangle* (sheet-medium stream) x1 y1 x2 y2
513 adejneka 1.52 :filled nil :ink +foreground-ink+)) ; XXX +FLIPPING-INK+?
514 adejneka 1.46 (:unhighlight
515     (draw-rectangle* (sheet-medium stream) x1 y1 x2 y2
516 adejneka 1.52 :filled nil :ink +background-ink+)))))) ; XXX +FLIPPING-INK+?
517 rouanet 1.11
518 adejneka 1.46 ;;; 16.2.2. The Output Record "Database" Protocol
519     (defmethod output-record-children ((record basic-output-record))
520     nil)
521 mikemac 1.1
522 adejneka 1.46 (defmethod add-output-record (child (record basic-output-record))
523     (declare (ignore child))
524     (error "Cannot add a child to ~S." record))
525 rouanet 1.11
526 adejneka 1.47 (defmethod add-output-record :before (child (record compound-output-record))
527     (let ((parent (output-record-parent child)))
528     (when parent
529     (restart-case
530     (error "~S already has a parent ~S." child parent)
531     (delete ()
532     :report "Delete from the old parent."
533     (delete-output-record child parent))))))
534    
535 adejneka 1.46 (defmethod add-output-record :after (child (record compound-output-record))
536 rouanet 1.11 (recompute-extent-for-new-child record child))
537    
538 adejneka 1.46 (defmethod delete-output-record (child (record basic-output-record)
539     &optional (errorp t))
540     (declare (ignore child))
541     (when errorp (error "Cannot delete a child from ~S." record)))
542 mikemac 1.1
543 adejneka 1.46 (defmethod delete-output-record :after (child (record compound-output-record)
544     &optional (errorp t))
545 rouanet 1.11 (declare (ignore errorp))
546     (with-bounding-rectangle* (x1 y1 x2 y2) child
547     (recompute-extent-for-changed-child record child x1 y1 x2 y2)))
548    
549 adejneka 1.46 (defmethod clear-output-record ((record basic-output-record))
550     (error "Cannot clear ~S." record))
551    
552     (defmethod clear-output-record :after ((record compound-output-record))
553     (with-slots (x y x1 y1 x2 y2) record
554     (setf x1 x y1 y
555     x2 x y2 y)))
556    
557     (defmethod output-record-count ((record basic-output-record))
558     0)
559 mikemac 1.1
560 adejneka 1.46 (defmethod map-over-output-records
561     (function (record basic-output-record)
562     &optional (x-offset 0) (y-offset 0)
563     &rest function-args)
564     (declare (ignore function x-offset y-offset function-args))
565     nil)
566 mikemac 1.1
567 adejneka 1.46 ;;; This needs to work in "most recently added last" order. Is this
568     ;;; implementation right? -- APD, 2002-06-13
569     #+nil
570 moore 1.39 (defmethod map-over-output-records
571 adejneka 1.46 (function (record compound-output-record)
572 moore 1.35 &optional (x-offset 0) (y-offset 0)
573     &rest function-args)
574     (declare (ignore x-offset y-offset))
575 adejneka 1.46 (map nil (lambda (child) (apply function child function-args))
576     (output-record-children record)))
577    
578     (defmethod map-over-output-records-containing-position
579     (function (record basic-output-record) x y
580     &optional (x-offset 0) (y-offset 0)
581     &rest function-args)
582     (declare (ignore function x y x-offset y-offset function-args))
583     nil)
584 moore 1.35
585 adejneka 1.46 ;;; This needs to work in "most recently added first" order. Is this
586     ;;; implementation right? -- APD, 2002-06-13
587     #+nil
588 moore 1.35 (defmethod map-over-output-records-containing-position
589 adejneka 1.46 (function (record compound-output-record) x y
590 moore 1.35 &optional (x-offset 0) (y-offset 0)
591     &rest function-args)
592 moore 1.36 (declare (ignore x-offset y-offset))
593 adejneka 1.46 (map nil
594     (lambda (child)
595     (when (and (multiple-value-bind (min-x min-y max-x max-y)
596 moore 1.39 (output-record-hit-detection-rectangle* child)
597     (and (<= min-x x max-x) (<= min-y y max-y)))
598     (output-record-refined-position-test child x y))
599 adejneka 1.46 (apply function child function-args)))
600     (output-record-children record)))
601    
602     (defmethod map-over-output-records-overlapping-region
603     (function (record basic-output-record) region
604     &optional (x-offset 0) (y-offset 0)
605     &rest function-args)
606     (declare (ignore function region x-offset y-offset function-args))
607     nil)
608 mikemac 1.1
609 adejneka 1.46 ;;; This needs to work in "most recently added last" order. Is this
610     ;;; implementation right? -- APD, 2002-06-13
611     #+nil
612 moore 1.35 (defmethod map-over-output-records-overlapping-region
613 adejneka 1.46 (function (record compound-output-record) region
614 moore 1.35 &optional (x-offset 0) (y-offset 0)
615     &rest function-args)
616     (declare (ignore x-offset y-offset))
617 adejneka 1.46 (map nil
618     (lambda (child) (when (region-intersects-region-p region child)
619     (apply function child function-args)))
620     (output-record-children record)))
621 mikemac 1.1
622 adejneka 1.46 ;;; 16.2.3. Output Record Change Notification Protocol
623 moore 1.39 (defmethod recompute-extent-for-new-child
624 adejneka 1.46 ((record compound-output-record) child)
625 rouanet 1.11 (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2) record
626 adejneka 1.46 (with-slots (parent x1 y1 x2 y2) record
627     (if (= 1 (length (output-record-children record)))
628 moore 1.34 (setf (values x1 y1 x2 y2) (bounding-rectangle* child))
629     (with-bounding-rectangle* (x1-child y1-child x2-child y2-child) child
630     (minf x1 x1-child)
631     (minf y1 y1-child)
632     (maxf x2 x2-child)
633     (maxf y2 y2-child)))
634 rouanet 1.11 (when parent
635 moore 1.34 (recompute-extent-for-changed-child parent record
636 adejneka 1.47 old-x1 old-y1 old-x2 old-y2))))
637     record)
638 mikemac 1.1
639 adejneka 1.46 (defmethod %tree-recompute-extent* ((record compound-output-record))
640     ;; Internal helper function
641 moore 1.34 (let ((new-x1 0)
642     (new-y1 0)
643     (new-x2 0)
644     (new-y2 0)
645     (first-time t))
646     (map-over-output-records
647 adejneka 1.46 (lambda (child)
648     (if first-time
649     (progn
650     (multiple-value-setq (new-x1 new-y1 new-x2 new-y2)
651     (bounding-rectangle* child))
652     (setq first-time nil))
653     (with-bounding-rectangle* (cx1 cy1 cx2 cy2) child
654     (minf new-x1 cx1)
655     (minf new-y1 cy1)
656     (maxf new-x2 cx2)
657     (maxf new-y2 cy2))))
658 moore 1.34 record)
659     (if first-time
660 adejneka 1.46 (with-slots (x y) record
661     (values x y x y))
662 moore 1.34 (values new-x1 new-y1 new-x2 new-y2))))
663    
664     (defmethod recompute-extent-for-changed-child
665 adejneka 1.46 ((record compound-output-record) changed-child
666 moore 1.34 old-min-x old-min-y old-max-x old-max-y)
667     ;; If the child's old and new bbox lies entirely within the record's bbox
668     ;; then no change need be made to the record's bbox. Otherwise, if some part
669     ;; of the child's bbox was on the record's bbox and is now inside, examine
670     ;; all the children to determine the correct new bbox.
671     (with-slots (x1 y1 x2 y2) record
672     (with-bounding-rectangle* (child-x1 child-y1 child-x2 child-y2)
673     changed-child
674 adejneka 1.46 (unless (and (> x1 old-min-x) (> x1 child-x1)
675     (> y1 old-min-y) (> y1 child-y1)
676     (< x2 old-max-x) (< x2 child-x2)
677     (< y2 old-max-y) (< y2 child-y2))
678 moore 1.34 ;; Don't know if changed-child has been deleted or what, so go through
679     ;; all the children and construct the updated bbox.
680 adejneka 1.47 (setf (values x1 y1 x2 y2) (%tree-recompute-extent* record)))))
681     record)
682 moore 1.34
683 adejneka 1.46 (defmethod recompute-extent-for-changed-child :around
684     ((record compound-output-record) child
685     old-min-x old-min-y old-max-x old-max-y)
686     (declare (ignore child old-min-x old-min-y old-max-x old-max-y))
687     (unless (slot-value record 'in-moving-p)
688 adejneka 1.47 (let ((old-rectangle (multiple-value-call #'make-bounding-rectangle
689     (bounding-rectangle* record))))
690 adejneka 1.46 (call-next-method)
691     (with-slots (parent x1 y1 x2 y2) record
692     (when (and parent (not (region-equal old-rectangle record)))
693 adejneka 1.47 (multiple-value-call #'recompute-extent-for-changed-child
694     (values parent record)
695     (bounding-rectangle* old-rectangle))))))
696     record)
697 adejneka 1.46
698     (defmethod tree-recompute-extent ((record compound-output-record))
699 moore 1.34 (with-slots (x1 y1 x2 y2) record
700 adejneka 1.47 (setf (values x1 y1 x2 y2) (%tree-recompute-extent* record)))
701     record)
702 mikemac 1.1
703 adejneka 1.46 (defmethod tree-recompute-extent :around ((record compound-output-record))
704 adejneka 1.47 (let ((old-rectangle (multiple-value-call #'make-bounding-rectangle
705     (bounding-rectangle* record))))
706 adejneka 1.22 (call-next-method)
707     (with-slots (parent x1 y1 x2 y2) record
708 adejneka 1.41 (when (and parent (not (region-equal old-rectangle record)))
709 adejneka 1.47 (recompute-extent-for-changed-child parent record x1 y1 x2 y2))))
710     record)
711 mikemac 1.1
712 adejneka 1.46 ;;; 16.3.1. Standard output record classes
713 mikemac 1.1
714 adejneka 1.46 (defclass standard-sequence-output-record (compound-output-record)
715     ((children :initform (make-array 8 :adjustable t :fill-pointer 0)
716     :reader output-record-children)))
717 moore 1.34
718 adejneka 1.46 (defmethod add-output-record (child (record standard-sequence-output-record))
719 adejneka 1.47 (vector-push-extend child (output-record-children record))
720     (setf (output-record-parent child) record))
721 mikemac 1.1
722 adejneka 1.46 (defmethod delete-output-record (child (record standard-sequence-output-record)
723     &optional (errorp t))
724     (with-slots (children) record
725     (let ((pos (position child children :test #'eq)))
726     (if (null pos)
727     (when errorp
728     (error "~S is not a child of ~S" child record))
729     (progn
730     (setq children (replace children children
731     :start1 pos
732     :start2 (1+ pos)))
733 adejneka 1.47 (decf (fill-pointer children))
734     (setf (output-record-parent child) nil))))))
735 mikemac 1.1
736 adejneka 1.46 (defmethod clear-output-record ((record standard-sequence-output-record))
737 adejneka 1.47 (let ((children (output-record-children record)))
738     (map 'nil (lambda (child) (setf (output-record-parent child) nil))
739     children)
740 adejneka 1.46 (fill children nil)
741     (setf (fill-pointer children) 0)))
742 rouanet 1.11
743 adejneka 1.46 (defmethod output-record-count ((record standard-sequence-output-record))
744     (length (output-record-children record)))
745 rouanet 1.11
746 adejneka 1.46 (defmethod map-over-output-records
747     (function (record standard-sequence-output-record)
748     &optional (x-offset 0) (y-offset 0)
749     &rest function-args)
750     "Applies FUNCTION to all children in the order they were added."
751     (declare (ignore x-offset y-offset))
752     (loop with children = (output-record-children record)
753     for child across children
754     do (apply function child function-args)))
755 mikemac 1.1
756 adejneka 1.46 (defmethod map-over-output-records-containing-position
757     (function (record standard-sequence-output-record) x y
758     &optional (x-offset 0) (y-offset 0)
759     &rest function-args)
760     "Applies FUNCTION to children, containing (X,Y), in the reversed
761     order they were added."
762     (declare (ignore x-offset y-offset))
763     (loop with children = (output-record-children record)
764     for i from (1- (length children)) downto 0
765     for child = (aref children i)
766     when (and (multiple-value-bind (min-x min-y max-x max-y)
767     (output-record-hit-detection-rectangle* child)
768     (and (<= min-x x max-x) (<= min-y y max-y)))
769     (output-record-refined-position-test child x y))
770     do (apply function child function-args)))
771 cvs 1.7
772 adejneka 1.46 (defmethod map-over-output-records-overlapping-region
773     (function (record standard-sequence-output-record) region
774     &optional (x-offset 0) (y-offset 0)
775     &rest function-args)
776     "Applies FUNCTION to children, overlapping REGION, in the order they
777     were added."
778     (declare (ignore x-offset y-offset))
779     (loop with children = (output-record-children record)
780     for child across children
781     when (region-intersects-region-p region child)
782     do (apply function child function-args)))
783 rouanet 1.11
784 adejneka 1.46 ;;; XXX bogus for now.
785     (defclass standard-tree-output-record (standard-sequence-output-record)
786     (
787     ))
788 mikemac 1.1
789 moore 1.57 (defmethod match-output-records ((record t) &rest args)
790     (apply #'match-output-records-1 record args))
791    
792     ;;; Factor out the graphics state portions of the output records so
793     ;;; they can be manipulated seperately e.g., by incremental
794     ;;; display. The individual slots of a graphics state are factored into mixin
795     ;;; classes so that each output record can capture only the state that it needs.
796     ;;; -- moore
797    
798     ;;; It would be appealing to define a setf method, e.g. (setf
799     ;;; medium-graphics-state), for setting a medium's state from a graphics state
800     ;;; object, but that would require us to define a medium-graphics-state reader
801     ;;; that would cons a state object. I don't want to do that.
802    
803     (defclass graphics-state ()
804     ()
805     (:documentation "Stores those parts of the medium/stream graphics state
806     that need to be restored when drawing an output record"))
807    
808     (defgeneric set-medium-graphics-state (state medium)
809     (:documentation "Sets the MEDIUM graphics state from STATE"))
810    
811     (defmethod set-medium-graphics-state (state medium)
812     (declare (ignore medium))
813     state)
814    
815     (defmethod set-medium-graphics-state (state (stream output-recording-stream))
816     (with-sheet-medium (medium stream)
817     (set-medium-graphics-state state medium)))
818    
819     (defclass gs-ink-mixin (graphics-state)
820     ((ink :initarg :ink :accessor graphics-state-ink)))
821    
822     (defmethod initialize-instance :after ((obj gs-ink-mixin)
823     &key (stream nil)
824     (medium (when stream
825     (sheet-medium stream))))
826     (when (and medium (not (slot-boundp obj 'ink)))
827     (setf (slot-value obj 'ink) (medium-ink medium))))
828    
829     (defmethod set-medium-graphics-state :after ((state gs-ink-mixin) medium)
830     (setf (medium-ink medium) (graphics-state-ink state)))
831    
832     (defmethod match-output-records-1 and ((record gs-ink-mixin)
833     &key (ink nil inkp))
834     (or (null inkp)
835     (design-equalp (graphics-state-ink record) ink)))
836    
837     (defclass gs-clip-mixin (graphics-state)
838     ((clip :initarg :clipping-region :accessor graphics-state-clip
839     :documentation "Clipping region in stream coordinates.")))
840    
841    
842     (defmethod initialize-instance :after ((obj gs-clip-mixin)
843     &key (stream nil)
844     (medium (when stream
845     (sheet-medium stream))))
846     (when medium
847     (with-slots (clip)
848     obj
849     (let ((clip-region (if (slot-boundp obj 'clip)
850     (region-intersection (medium-clipping-region
851     medium)
852     clip)
853     (medium-clipping-region medium))))
854     (setq clip (transform-region (medium-transformation medium)
855     clip-region))))))
856    
857     (defmethod set-medium-graphics-state :after ((state gs-clip-mixin) medium)
858 gilbert 1.59 ;;
859     ;; This definition is kind of wrong. When output records are about to
860     ;; be replayed only a certain region of the stream should be affected.[1]
861     ;; Therefore I disabled this code, since this way only breaks the
862     ;; [not very frequent case] that the output record actually contains
863     ;; a clipping region different from +everywhere+, while having it in
864     ;; breaks redisplay of streams in just about every case.
865     ;;
866     ;; Most notably Closure is affected by this, as it does the equivalent of
867     ;; (draw-rectangle* medium 0 0 800 200 :ink +white+ :filled t)
868     ;; (draw-text* medium "Hello" 100 100)
869     ;;
870     ;; Having this code in a redisplay on the region
871     ;; (make-rectangle* 0 0 50 50) fills the drawing pane with a white
872     ;; rectangle obscuring the text.
873     ;;
874     ;; [1] it is of course debatable where this extra clipping because
875     ;; of redisplay should come from. Should replay-output-record set it
876     ;; up? Should handle-repaint do so?
877     ;;
878     ;; --GB 2003-03-14
879 mikemac 1.61 #+nil
880 moore 1.57 (setf (medium-clipping-region medium) (graphics-state-clip state)))
881    
882     (defmethod match-output-records-1 and ((record gs-clip-mixin)
883     &key (clip nil clipp))
884     (or clipp
885     (region-equal (graphics-state-clip record) clip)))
886    
887 adejneka 1.46 ;;; 16.3.2. Graphics Displayed Output Records
888 moore 1.57 (defclass standard-displayed-output-record (gs-clip-mixin gs-ink-mixin
889     basic-output-record
890 adejneka 1.46 displayed-output-record)
891 moore 1.57 ((ink :reader displayed-output-record-ink))
892 adejneka 1.46 (:documentation "Implementation class for DISPLAYED-OUTPUT-RECORD."))
893 mikemac 1.1
894 moore 1.57 (defclass gs-line-style-mixin (graphics-state)
895     ((line-style :initarg :line-style :accessor graphics-state-line-style)))
896    
897     (defmethod initialize-instance :after ((obj gs-line-style-mixin)
898     &key (stream nil)
899     (medium (when stream
900     (sheet-medium stream))))
901     (when medium
902     (unless (slot-boundp obj 'line-style)
903     (setf (slot-value obj 'line-style) (medium-line-style medium)))))
904    
905     (defmethod set-medium-graphics-state :after ((state gs-line-style-mixin) medium)
906     (setf (medium-line-style medium) (graphics-state-line-style state)))
907    
908     (defmethod match-output-records-1 and ((record gs-line-style-mixin)
909     &key (line-style nil line-style-p))
910     (or (null line-style-p)
911     (line-style-equalp (graphics-state-line-style record) line-style)))
912    
913     (defgeneric graphics-state-line-style-border (record medium)
914     (:method ((record gs-line-style-mixin) medium)
915     (/ (line-style-effective-thickness (graphics-state-line-style record)
916     medium)
917     2)))
918    
919     (defclass gs-text-style-mixin (graphics-state)
920     ((text-style :initarg :text-style :accessor graphics-state-text-style)))
921    
922     (defmethod initialize-instance :after ((obj gs-text-style-mixin)
923     &key (stream nil)
924     (medium (when stream
925     (sheet-medium stream))))
926     (when medium
927     (unless (slot-boundp obj 'text-style)
928     (setf (slot-value obj 'text-style) (medium-text-style medium)))))
929    
930     (defmethod set-medium-graphics-state :after ((state gs-text-style-mixin) medium)
931     (setf (medium-text-style medium) (graphics-state-text-style state)))
932    
933     (defmethod match-output-records-1 and ((record gs-text-style-mixin)
934     &key (text-style nil text-style-p))
935     (or (null text-style-p)
936     (text-style-equalp (graphics-state-text-style record) text-style)))
937    
938 adejneka 1.46 (defclass standard-graphics-displayed-output-record
939 moore 1.57 (standard-displayed-output-record
940     graphics-displayed-output-record)
941     ())
942    
943     (defmethod match-output-records-1 and
944     ((record standard-displayed-output-record)
945     &key (x1 nil x1-p) (y1 nil y1-p)
946     (x2 nil x2-p) (y2 nil y2-p)
947     (bounding-rectangle nil bounding-rectangle-p))
948     (if bounding-rectangle-p
949     (region-equal record bounding-rectangle)
950     (multiple-value-bind (my-x1 my-y1 my-x2 my-y2)
951     (bounding-rectangle* record)
952     (and (or (null x1-p) (coordinate= my-x1 x1))
953     (or (null y1-p) (coordinate= my-y1 y1))
954     (or (null x2-p) (coordinate= my-x2 x2))
955     (or (null y2-p) (coordinate= my-y2 y2))))))
956    
957     ;;; This is an around method so that more specific before methods can be
958     ;;; defined for the various mixin classes, that modify the state after it has
959     ;;; been set in the graphics state.
960    
961     (defmethod replay-output-record :around
962     ((record standard-displayed-output-record) stream
963     &optional region x-offset y-offset)
964     (declare (ignore region x-offset y-offset))
965     (set-medium-graphics-state record stream)
966     (call-next-method))
967    
968     (defclass coord-seq-mixin ()
969     ((coord-seq :accessor coord-seq :initarg :coord-seq))
970     (:documentation "Mixin class that implements methods for records that contain
971     sequences of coordinates."))
972    
973     (defun coord-seq-bounds (coord-seq border)
974     (let* ((min-x (elt coord-seq 0))
975     (min-y (elt coord-seq 1))
976     (max-x min-x)
977     (max-y min-y))
978     (do-sequence ((x y) coord-seq)
979     (minf min-x x)
980     (minf min-y y)
981     (maxf max-x x)
982     (maxf max-y y))
983     (values (- min-x border) (- min-y border)
984     (+ max-x border) (+ max-y border))))
985    
986     (defmethod initialize-instance :after ((record coord-seq-mixin) &key)
987     (let ((medium (sheet-medium (slot-value record 'stream))))
988     (with-slots (coord-seq)
989     record
990     (setf coord-seq
991     (transform-position-sequence 'vector
992     (medium-transformation medium)
993     coord-seq)))))
994    
995     ;;; x1, y1 slots must exist in class...
996 mikemac 1.1
997 moore 1.57 (defmethod* (setf output-record-position) :around
998     (nx ny (record coord-seq-mixin))
999     (with-slots (x1 y1)
1000     record
1001     (let ((dx (- nx x1))
1002     (dy (- ny y1))
1003     (coords (slot-value record 'coord-seq)))
1004     (multiple-value-prog1
1005     (call-next-method)
1006     (loop for i from 0 below (length coords) by 2
1007     do (progn
1008     (incf (aref coords i) dx)
1009 gilbert 1.59 (incf (aref coords (1+ i)) dy)))))))
1010 moore 1.57
1011     (defmethod match-output-records-1 and ((record coord-seq-mixin)
1012     &key (coord-seq nil coord-seq-p))
1013     (or (null coord-seq-p)
1014     (let* ((my-coord-seq (slot-value record 'coord-seq))
1015     (len (length my-coord-seq)))
1016     (and (eql len (length coord-seq))
1017     (loop for elt1 across my-coord-seq
1018     for elt2 across coord-seq
1019     always (coordinate= elt1 elt2))))))
1020    
1021     ;;; Do we need to save/restore graphics state in each call to
1022     ;;; replay-output-record, or could we do it only in replay? I'd like to save
1023     ;;; state in a graphics state object, but I'm not going to allocate one in each
1024     ;;; recursive invocation of replay-output-record :P -- moore
1025    
1026     (defmacro def-grecording (name ((&rest mixins) &rest args) &body body)
1027 gilbert 1.56 (let ((method-name (symbol-concat '#:medium- name '*))
1028 moore 1.57 (class-name (symbol-concat name '#:-OUTPUT-RECORD))
1029 adejneka 1.41 (medium (gensym "MEDIUM"))
1030 adejneka 1.46 (class-vars `((stream :initarg :stream)
1031     ,@(loop for arg in args
1032     collect `(,arg
1033     :initarg ,(intern (symbol-name arg)
1034     :keyword)))))
1035     (arg-list (loop for arg in args
1036     nconc `(,(intern (symbol-name arg) :keyword) ,arg))))
1037 cvs 1.10 `(progn
1038 moore 1.57 (defclass ,class-name (,@mixins standard-graphics-displayed-output-record)
1039 adejneka 1.46 ,class-vars)
1040 mikemac 1.1 (defmethod initialize-instance :after ((graphic ,class-name) &rest args)
1041     (declare (ignore args))
1042 moore 1.57 (with-slots (x1 y1 x2 y2
1043     stream ink clipping-region
1044     line-style text-style ,@args)
1045     graphic
1046 strandh 1.58 (let* ((medium (sheet-medium stream)))
1047 moore 1.57 (multiple-value-setq (x1 y1 x2 y2) (progn ,@body)))))
1048 rouanet 1.11 (defmethod ,method-name :around ((stream output-recording-stream) ,@args)
1049 adejneka 1.47 ;; XXX STANDARD-OUTPUT-RECORDING-STREAM ^?
1050 mikemac 1.1 (with-sheet-medium (medium stream)
1051 cvs 1.5 (when (stream-recording-p stream)
1052     (let ((record (make-instance ',class-name
1053     :stream stream
1054 adejneka 1.46 ,@arg-list)))
1055 rouanet 1.11 (stream-add-output-record stream record)))
1056 cvs 1.5 (when (stream-drawing-p stream)
1057     (call-next-method))))
1058 mikemac 1.1 (defmethod replay-output-record ((record ,class-name) stream
1059 rouanet 1.18 &optional (region +everywhere+)
1060     (x-offset 0) (y-offset 0))
1061 moore 1.57 (declare (ignore x-offset y-offset region))
1062     (with-slots (,@args) record
1063     (let ((,medium (sheet-medium stream))
1064 adejneka 1.41 ;; is sheet a sheet-with-medium-mixin? --GB
1065     )
1066 moore 1.57 ;; Graphics state is set up in :around method.
1067     (,method-name ,medium ,@args)))))))
1068 mikemac 1.1
1069 moore 1.57 (def-grecording draw-point ((gs-line-style-mixin) point-x point-y)
1070     (let ((border (graphics-state-line-style-border graphic medium)))
1071     (with-transformed-position ((medium-transformation medium) point-x point-y)
1072     (setf (slot-value graphic 'point-x) point-x
1073     (slot-value graphic 'point-y) point-y)
1074     (values (- point-x border)
1075     (- point-y border)
1076     (+ point-x border)
1077     (+ point-y border)))))
1078    
1079     (defmethod* (setf output-record-position) :around
1080     (nx ny (record draw-point-output-record))
1081     (with-slots (x1 y1 point-x point-y)
1082     record
1083     (let ((dx (- nx x1))
1084     (dy (- ny y1)))
1085     (multiple-value-prog1
1086     (call-next-method)
1087     (incf point-x dx)
1088     (incf point-y dy)))))
1089    
1090     (defmethod match-output-records-1 and ((record draw-point-output-record)
1091     &key (point-x nil point-x-p)
1092     (point-y nil point-y-p))
1093     (and (or (null point-x-p)
1094     (coordinate= (slot-value record 'point-x) point-x))
1095     (or (null point-y-p)
1096     (coordinate= (slot-value record 'point-y) point-y))))
1097    
1098    
1099     (def-grecording draw-points ((coord-seq-mixin gs-line-style-mixin) coord-seq)
1100     ;; coord-seq has already been transformed
1101     (let ((border (graphics-state-line-style-border graphic medium)))
1102     (coord-seq-bounds coord-seq border)))
1103    
1104     (def-grecording draw-line ((gs-line-style-mixin)
1105     point-x1 point-y1 point-x2 point-y2)
1106     (let ((transform (medium-transformation medium))
1107     (border (graphics-state-line-style-border graphic medium)))
1108     (with-transformed-position (transform point-x1 point-y1)
1109     (with-transformed-position (transform point-x2 point-y2)
1110     (setf (slot-value graphic 'point-x1) point-x1
1111     (slot-value graphic 'point-y1) point-y1
1112     (slot-value graphic 'point-x2) point-x2
1113     (slot-value graphic 'point-y2) point-y2)
1114     (values (- (min point-x1 point-x2) border)
1115     (- (min point-y1 point-y2) border)
1116     (+ (max point-x1 point-x2) border)
1117     (+ (max point-y1 point-y2) border))))))
1118    
1119     (defmethod* (setf output-record-position) :around
1120     (nx ny (record draw-line-output-record))
1121     (with-slots (x1 y1
1122     point-x1 point-y1 point-x2 point-y2)
1123     record
1124     (let ((dx (- nx x1))
1125     (dy (- ny y1)))
1126     (multiple-value-prog1
1127     (call-next-method)
1128     (incf point-x1 dx)
1129     (incf point-y1 dy)
1130     (incf point-x2 dx)
1131     (incf point-y2 dy)))))
1132    
1133     (defmethod match-output-records-1 and ((record draw-line-output-record)
1134     &key (point-x1 nil point-x1-p)
1135     (point-y1 nil point-y1-p)
1136     (point-x2 nil point-x2-p)
1137     (point-y2 nil point-y2-p))
1138     (and (or (null point-x1-p)
1139     (coordinate= (slot-value record 'point-x1) point-x1))
1140     (or (null point-y1-p)
1141     (coordinate= (slot-value record 'point-y1) point-y1))
1142     (or (null point-x2-p)
1143     (coordinate= (slot-value record 'point-x2) point-x2))
1144     (or (null point-y2-p)
1145     (coordinate= (slot-value record 'point-y2) point-y2))))
1146    
1147    
1148     (def-grecording draw-lines ((coord-seq-mixin gs-line-style-mixin) coord-seq)
1149     (let ((border (graphics-state-line-style-border graphic medium)))
1150     (coord-seq-bounds coord-seq border)))
1151    
1152     ;;; Helper function
1153     (defun normalize-coords (dx dy &optional unit)
1154     (let ((norm (sqrt (+ (* dx dx) (* dy dy)))))
1155     (if unit
1156     (let ((scale (/ unit norm)))
1157     (values (* dx scale) (* dy scale)))
1158     (values (/ dx norm) (/ dy norm)))))
1159 mikemac 1.1
1160 adejneka 1.52 (defun polygon-record-bounding-rectangle
1161 moore 1.57 (coord-seq closed filled line-style border miter-limit)
1162 moore 1.54 (cond (filled
1163 moore 1.57 (coord-seq-bounds coord-seq 0))
1164 moore 1.54 ((eq (line-style-joint-shape line-style) :round)
1165 moore 1.57 (coord-seq-bounds coord-seq border))
1166     (t (let* ((x1 (svref coord-seq 0))
1167     (y1 (svref coord-seq 1))
1168     (min-x x1)
1169     (min-y y1)
1170     (max-x x1)
1171     (max-y y1)
1172     (len (length coord-seq)))
1173     (unless closed
1174     (setq min-x (- x1 border) min-y (- y1 border)
1175     max-x (+ x1 border) max-y (+ y1 border)))
1176     ;; Setup for iterating over the coordinate vector. If the polygon
1177     ;; is closed deal with the extra segment.
1178     (multiple-value-bind (initial-xp initial-yp
1179     final-xn final-yn
1180     initial-index final-index)
1181     (if closed
1182     (values (svref coord-seq (- len 2))
1183     (svref coord-seq (- len 1))
1184     x1 y1
1185     0 (- len 2))
1186     (values x1 y1
1187     (svref coord-seq (- len 2))
1188     (svref coord-seq (- len 1))
1189     2 (- len 4)))
1190     (ecase (line-style-joint-shape line-style)
1191     (:miter
1192     ;;FIXME: Remove successive positively proportional segments
1193     (loop with sin-limit = (sin (* 0.5 miter-limit))
1194     and xn and yn
1195     for i from initial-index to final-index by 2
1196     for xp = initial-xp then x
1197     for yp = initial-yp then y
1198     for x = (svref coord-seq i)
1199     for y = (svref coord-seq (1+ i))
1200     do (setf (values xn yn)
1201     (if (eql i final-index)
1202     (values final-xn final-yn)
1203     (values (svref coord-seq (+ i 2))
1204     (svref coord-seq (+ i
1205     3)))))
1206     (multiple-value-bind (ex1 ey1)
1207     (normalize-coords (- x xp) (- y yp))
1208     (multiple-value-bind (ex2 ey2)
1209     (normalize-coords (- x xn) (- y yn))
1210     (let* ((cos-a (+ (* ex1 ex2) (* ey1 ey2)))
1211     (sin-a/2 (sqrt (* 0.5 (- 1.0 cos-a)))))
1212     (if (< sin-a/2 sin-limit)
1213     (let ((nx (* border
1214     (max (abs ey1) (abs ey2))))
1215     (ny (* border
1216     (max (abs ex1) (abs ex2)))))
1217     (minf min-x (- x nx))
1218     (minf min-y (- y ny))
1219     (maxf max-x (+ x nx))
1220     (maxf max-y (+ y ny)))
1221     (let ((length (/ border sin-a/2)))
1222     (multiple-value-bind (dx dy)
1223     (normalize-coords (+ ex1 ex2)
1224     (+ ey1 ey2)
1225     length)
1226     (minf min-x (+ x dx))
1227     (minf min-y (+ y dy))
1228     (maxf max-x (+ x dx))
1229     (maxf max-y (+ y dy))))))))))
1230     ((:bevel :none)
1231     (loop with xn and yn
1232     for i from initial-index to final-index by 2
1233     for xp = initial-xp then x
1234     for yp = initial-yp then y
1235     for x = (svref coord-seq i)
1236     for y = (svref coord-seq (1+ i))
1237     do (setf (values xn yn)
1238     (if (eql i final-index)
1239     (values final-xn final-yn)
1240     (values (svref coord-seq (+ i 2))
1241     (svref coord-seq (+ i
1242     3)))))
1243     (multiple-value-bind (ex1 ey1)
1244     (normalize-coords (- x xp) (- y yp))
1245     (multiple-value-bind (ex2 ey2)
1246     (normalize-coords (- x xn) (- y yn))
1247     (let ((nx (* border (max (abs ey1) (abs ey2))))
1248     (ny (* border (max (abs ex1) (abs ex2)))))
1249     (minf min-x (- x nx))
1250     (minf min-y (- y ny))
1251     (maxf max-x (+ x nx))
1252     (maxf max-y (+ y ny))))))))
1253     (unless closed
1254     (multiple-value-bind (x y)
1255     (values (svref coord-seq final-index)
1256     (svref coord-seq (1+ final-index)))
1257     (minf min-x (- x border))
1258     (minf min-y (- y border))
1259     (maxf max-x (+ x border))
1260     (maxf max-y (+ y border)))))
1261     (values min-x min-y max-x max-y)))))
1262    
1263     (def-grecording draw-polygon ((coord-seq-mixin gs-line-style-mixin)
1264     coord-seq closed filled)
1265     (let ((border (graphics-state-line-style-border graphic medium)))
1266     (polygon-record-bounding-rectangle
1267     coord-seq closed filled line-style border (medium-miter-limit medium))))
1268    
1269     (defmethod match-output-records-1 and ((record draw-polygon-output-record)
1270     &key (closed nil closedp)
1271     (filled nil filledp))
1272     (and (or (null closedp)
1273     (eql (slot-value record 'closed) closed))
1274     (or (null filledp)
1275     (eql (slot-value record 'filled) filled))))
1276    
1277     (def-grecording draw-rectangle ((gs-line-style-mixin)
1278     left top right bottom filled)
1279     (let ((border (graphics-state-line-style-border graphic medium)))
1280     (polygon-record-bounding-rectangle
1281     (vector left top left bottom right bottom right top)
1282     t filled line-style border
1283     (medium-miter-limit medium))))
1284    
1285     (defmethod* (setf output-record-position) :around
1286     (nx ny (record draw-rectangle-output-record))
1287     (with-slots (x1 y1
1288     left top right bottom)
1289     record
1290     (let ((dx (- nx x1))
1291     (dy (- ny y1)))
1292     (multiple-value-prog1
1293     (call-next-method)
1294     (incf left dx)
1295     (incf top dy)
1296     (incf right dx)
1297     (incf bottom dy)))))
1298    
1299     (defmethod match-output-records-1 and ((record draw-rectangle-output-record)
1300     &key (left nil leftp)
1301     (top nil topp)
1302     (right nil rightp)
1303     (bottom nil bottomp)
1304     (filled nil filledp))
1305     (and (or (null leftp)
1306     (coordinate= (slot-value record 'left) left))
1307     (or (null topp)
1308     (coordinate= (slot-value record 'top) top))
1309     (or (null rightp)
1310     (coordinate= (slot-value record 'right) right))
1311     (or (null bottomp)
1312     (coordinate= (slot-value record 'bottom) bottom))
1313     (or (null filledp)
1314     (eql (slot-value record 'filled) filled))))
1315 mikemac 1.1
1316 moore 1.57 (def-grecording draw-ellipse ((gs-line-style-mixin)
1317     center-x center-y
1318 mikemac 1.1 radius-1-dx radius-1-dy radius-2-dx radius-2-dy
1319     start-angle end-angle filled)
1320 adejneka 1.44 (multiple-value-bind (min-x min-y max-x max-y)
1321 moore 1.57 (bounding-rectangle* (make-ellipse* center-x center-y
1322     radius-1-dx radius-1-dy
1323     radius-2-dx radius-2-dy
1324     :start-angle start-angle
1325     :end-angle end-angle))
1326 adejneka 1.44 (if filled
1327     (values min-x min-y max-x max-y)
1328 moore 1.57 (let ((border (graphics-state-line-style-border graphic medium)))
1329     (values (- min-x border)
1330     (- min-y border)
1331     (+ max-x border)
1332     (+ max-y border))))))
1333    
1334     (defmethod* (setf output-record-position) :around
1335     (nx ny (record draw-ellipse-output-record))
1336     (with-slots (x1 y1 center-x center-y)
1337     record
1338     (let ((dx (- nx x1))
1339     (dy (- ny y1)))
1340     (multiple-value-prog1
1341     (call-next-method)
1342     (incf center-x dx)
1343     (incf center-y dy)))))
1344    
1345     (defmethod match-output-records-1 and ((record draw-ellipse-output-record)
1346     &key (center-x nil center-x-p)
1347     (center-y nil center-y-p))
1348     (and (or (null center-x-p)
1349     (coordinate= (slot-value record 'center-x) center-x))
1350     (or (null center-y-p)
1351     (coordinate= (slot-value record 'center-y) center-y))))
1352 rouanet 1.11
1353 moore 1.57 (def-grecording draw-text ((gs-text-style-mixin) string point-x point-y start end
1354 rouanet 1.11 align-x align-y toward-x toward-y transform-glyphs)
1355 adejneka 1.44 ;; FIXME!!! Text direction.
1356 adejneka 1.43 ;; Multiple lines?
1357 moore 1.57 (let* ((text-style (graphics-state-text-style graphic))
1358     (width (stream-string-width stream string
1359 rouanet 1.11 :start start :end end
1360     :text-style text-style))
1361 strandh 1.26 (ascent (text-style-ascent text-style (sheet-medium stream)))
1362     (descent (text-style-descent text-style (sheet-medium stream)))
1363 rouanet 1.11 (height (+ ascent descent))
1364     left top right bottom)
1365     (ecase align-x
1366     (:left (setq left point-x
1367     right (+ point-x width)))
1368     (:right (setq left (- point-x width)
1369     right point-x))
1370     (:center (setq left (- point-x (round width 2))
1371     right (+ point-x (round width 2)))))
1372     (ecase align-y
1373 adejneka 1.43 (:baseline (setq top (- point-y ascent)
1374 rouanet 1.11 bottom (+ point-y descent)))
1375     (:top (setq top point-y
1376     bottom (+ point-y height)))
1377     (:bottom (setq top (- point-y height)
1378     bottom point-y))
1379     (:center (setq top (- point-y (floor height 2))
1380     bottom (+ point-y (ceiling height 2)))))
1381     (values left top right bottom)))
1382 mikemac 1.1
1383 moore 1.57 (defmethod* (setf output-record-position) :around
1384     (nx ny (record draw-text-output-record))
1385     (with-slots (x1 y1 point-x point-y toward-x toward-y)
1386     record
1387     (let ((dx (- nx x1))
1388     (dy (- ny y1)))
1389     (multiple-value-prog1
1390     (call-next-method)
1391     (incf point-x dx)
1392     (incf point-y dy)
1393     (incf toward-x dx)
1394     (incf toward-y dy)))))
1395    
1396     (defmethod match-output-records-1 and ((record draw-text-output-record)
1397     &key (string nil stringp)
1398     (start nil startp)
1399     (end nil endp)
1400     (point-x nil point-x-p)
1401     (point-y nil point-y-p)
1402     (align-x nil align-x-p)
1403     (align-y nil align-y-p)
1404     (toward-x nil toward-x-p)
1405     (toward-y nil toward-y-p)
1406     (transform-glyphs nil
1407     transform-glyphs-p))
1408     (and (or (null stringp)
1409     (string= (slot-value record 'string) string))
1410     (or (null startp)
1411     (eql (slot-value record 'start) start))
1412     (or (null endp)
1413     (eql (slot-value record 'end) end))
1414     (or (null point-x-p)
1415     (coordinate= (slot-value record 'point-x) point-x))
1416     (or (null point-y-p)
1417     (coordinate= (slot-value record 'point-y) point-y))
1418     (or (null align-x-p)
1419     (eq (slot-value record 'align-x) align-x))
1420     (or (null align-y-p)
1421     (eq (slot-value record 'align-y) align-y))
1422     (or (null toward-x-p)
1423     (coordinate= (slot-value record 'toward-x) toward-x))
1424     (or (null toward-y-p)
1425     (coordinate= (slot-value record 'toward-y) toward-y))
1426     (or (null transform-glyphs-p)
1427     (eq (slot-value record 'transform-glyphs) transform-glyphs))))
1428    
1429 adejneka 1.46 ;;; 16.3.3. Text Displayed Output Record
1430 adejneka 1.47 (defvar *drawing-options* (list +foreground-ink+ +everywhere+)
1431     "The ink and the clipping region of the current stream.") ; XXX TDO
1432    
1433 moore 1.57 (defclass styled-string (gs-text-style-mixin gs-clip-mixin gs-ink-mixin)
1434 adejneka 1.47 ((start-x :initarg :start-x)
1435     (string :initarg :string :reader styled-string-string)))
1436 moore 1.34
1437 adejneka 1.46 (defclass standard-text-displayed-output-record
1438     (text-displayed-output-record standard-displayed-output-record)
1439 adejneka 1.47 ((initial-x1 :initarg :start-x)
1440     (initial-y1 :initarg :start-y)
1441     (strings :initform nil)
1442 mikemac 1.1 (baseline :initform 0)
1443 adejneka 1.22 (width :initform 0)
1444 mikemac 1.1 (max-height :initform 0)
1445 cvs 1.6 (start-x :initarg :start-x)
1446     (start-y :initarg :start-y)
1447 adejneka 1.47 (end-x :initarg :start-x)
1448     (end-y :initarg :start-y)
1449 cvs 1.8 (wrapped :initform nil
1450 moore 1.57 :accessor text-record-wrapped)
1451     (medium :initarg :medium :initform nil)))
1452    
1453     (defmethod initialize-instance :after
1454     ((obj standard-text-displayed-output-record) &key stream)
1455     (when stream
1456     (setf (slot-value obj 'medium) (sheet-medium stream))))
1457 mikemac 1.1
1458 adejneka 1.46 (defmethod print-object ((self standard-text-displayed-output-record) stream)
1459 cvs 1.8 (print-unreadable-object (self stream :type t :identity t)
1460 adejneka 1.47 (with-slots (start-x start-y strings) self
1461     (format stream "~D,~D ~S"
1462     start-x start-y
1463     (mapcar #'styled-string-string strings)))))
1464 mikemac 1.1
1465 moore 1.34 (defmethod* (setf output-record-position) :before
1466 adejneka 1.46 (nx ny (record standard-text-displayed-output-record))
1467 moore 1.57 (with-slots (x1 y1 start-x start-y end-x end-y strings) record
1468 adejneka 1.46 (let ((dx (- nx x1))
1469     (dy (- ny y1)))
1470 rouanet 1.23 (incf start-x dx)
1471     (incf start-y dy)
1472     (incf end-x dx)
1473 moore 1.57 (incf end-y dy)
1474     (loop for s in strings
1475     do (incf (slot-value s 'start-x) dx)))))
1476 cvs 1.9
1477 adejneka 1.46 (defmethod replay-output-record ((record standard-text-displayed-output-record)
1478 moore 1.34 stream
1479 adejneka 1.21 &optional region (x-offset 0) (y-offset 0))
1480 adejneka 1.46 (declare (ignore region x-offset y-offset))
1481 moore 1.57 (with-slots (strings baseline max-height start-y wrapped x1 y1)
1482     record
1483 adejneka 1.47 (with-sheet-medium (medium stream) ;is sheet a sheet-with-medium-mixin? --GB
1484 moore 1.57 ;; FIXME:
1485     ;; 1. SLOT-VALUE...
1486     ;; 2. It should also save a "current line".
1487     (setf (slot-value stream 'baseline) baseline)
1488     (loop for substring in strings
1489     do (with-slots (start-x string)
1490     substring
1491     (setf (stream-cursor-position stream)
1492     (values start-x start-y))
1493     (set-medium-graphics-state substring medium)
1494     (stream-write-line stream string)))
1495     (when wrapped ; FIXME
1496     (draw-rectangle* medium
1497     (+ wrapped 0) start-y
1498     (+ wrapped 4) (+ start-y max-height)
1499     :ink +foreground-ink+
1500     :filled t)))))
1501 mikemac 1.1
1502 moore 1.34 (defmethod output-record-start-cursor-position
1503 adejneka 1.46 ((record standard-text-displayed-output-record))
1504 mikemac 1.1 (with-slots (start-x start-y) record
1505     (values start-x start-y)))
1506    
1507 moore 1.34 (defmethod output-record-end-cursor-position
1508 adejneka 1.46 ((record standard-text-displayed-output-record))
1509 mikemac 1.1 (with-slots (end-x end-y) record
1510     (values end-x end-y)))
1511    
1512 adejneka 1.46 (defmethod tree-recompute-extent
1513     ((text-record standard-text-displayed-output-record))
1514     (with-slots (parent x1 y1 x2 y2 width max-height) text-record
1515     (setq x2 (coordinate (+ x1 width))
1516 adejneka 1.47 y2 (coordinate (+ y1 max-height))))
1517     text-record)
1518 adejneka 1.46
1519 adejneka 1.47 (defmethod add-character-output-to-text-record ; XXX OAOO with ADD-STRING-...
1520 adejneka 1.46 ((text-record standard-text-displayed-output-record)
1521     character text-style char-width height new-baseline)
1522 moore 1.57 (with-slots (strings baseline width max-height start-y end-x end-y medium)
1523     text-record
1524     (if (and strings
1525     (let ((string (last1 strings)))
1526     (match-output-records string
1527     :text-style text-style
1528     :ink (medium-ink medium)
1529     :clipping-region (medium-clipping-region
1530     medium))))
1531     (vector-push-extend character (slot-value (last1 strings) 'string))
1532     (nconcf strings
1533     (list (make-instance
1534     'styled-string
1535     :start-x end-x
1536     :text-style text-style
1537     :medium medium ; pick up ink and clipping region
1538     :string (make-array 1 :initial-element character
1539     :element-type 'character
1540     :adjustable t
1541     :fill-pointer t)))))
1542     (setq baseline (max baseline new-baseline)
1543     end-x (+ end-x char-width)
1544     max-height (max max-height height)
1545     end-y (max end-y (+ start-y max-height))
1546     width (+ width char-width)))
1547 adejneka 1.46 (tree-recompute-extent text-record))
1548    
1549     (defmethod add-string-output-to-text-record
1550     ((text-record standard-text-displayed-output-record)
1551     string start end text-style string-width height new-baseline)
1552     (if end
1553     (setq end (min end (length string)))
1554     (setq end (length string)))
1555     (let ((length (max 0 (- end start))))
1556     (cond
1557 moore 1.57 ((eql length 1)
1558 adejneka 1.47 (add-character-output-to-text-record text-record
1559     (aref string start)
1560     text-style
1561     string-width height new-baseline))
1562 moore 1.57 (t (with-slots (strings baseline width max-height start-y end-x end-y
1563     medium)
1564     text-record
1565     (let ((styled-string (make-instance
1566     'styled-string
1567     :start-x end-x
1568     :text-style text-style
1569     :medium medium
1570     :string (make-array (length string)
1571     :element-type 'character
1572     :adjustable t
1573     :fill-pointer t))))
1574     (nconcf strings (list styled-string))
1575     (replace (styled-string-string styled-string) string
1576     :start2 start :end2 end))
1577     (setq baseline (max baseline new-baseline)
1578     end-x (+ end-x string-width)
1579     max-height (max max-height height)
1580     end-y (max end-y (+ start-y max-height))
1581     width (+ width string-width)))
1582 adejneka 1.47 (tree-recompute-extent text-record)))))
1583 adejneka 1.46
1584 moore 1.34 (defmethod text-displayed-output-record-string
1585 adejneka 1.46 ((record standard-text-displayed-output-record))
1586     (with-output-to-string (result)
1587     (with-slots (strings) record
1588     (loop for (nil nil substring) in strings
1589     do (write-string substring result)))))
1590    
1591     ;;; 16.3.4. Top-Level Output Records
1592     (defclass stream-output-history-mixin ()
1593     ())
1594    
1595     (defclass standard-sequence-output-history
1596     (standard-sequence-output-record stream-output-history-mixin)
1597     ())
1598 cvs 1.5
1599 adejneka 1.46 (defclass standard-tree-output-history
1600     (standard-tree-output-record stream-output-history-mixin)
1601 moore 1.34 ())
1602    
1603 adejneka 1.46 ;;; 16.4. Output Recording Streams
1604     (defclass standard-output-recording-stream (output-recording-stream)
1605     ((recording-p :initform t :reader stream-recording-p)
1606     (drawing-p :initform t :accessor stream-drawing-p)
1607     (output-history :initform (make-instance 'standard-tree-output-history)
1608     :reader stream-output-history)
1609     (current-output-record :accessor stream-current-output-record)
1610     (current-text-output-record :initform nil
1611     :accessor stream-current-text-output-record)
1612     (local-record-p :initform t
1613     :documentation "This flag is used for dealing with streams outputting strings char-by-char.")))
1614    
1615     (defmethod initialize-instance :after
1616     ((stream standard-output-recording-stream) &rest args)
1617     (declare (ignore args))
1618     (setf (stream-current-output-record stream) (stream-output-history stream)))
1619    
1620 moore 1.55 ;;; Used in initializing clim-stream-pane
1621    
1622     (defmethod reset-output-history ((stream
1623     standard-output-recording-stream))
1624     (setf (slot-value stream 'output-history)
1625     (make-instance 'standard-tree-output-history))
1626     (setf (stream-current-output-record stream) (stream-output-history stream)))
1627    
1628 adejneka 1.46 ;;; 16.4.1 The Output Recording Stream Protocol
1629     (defmethod (setf stream-recording-p)
1630     (recording-p (stream standard-output-recording-stream))
1631     (let ((old-val (slot-value stream 'recording-p)))
1632     (setf (slot-value stream 'recording-p) recording-p)
1633     (when (not (eq old-val recording-p))
1634     (stream-close-text-output-record stream))
1635     recording-p))
1636    
1637     (defmethod stream-add-output-record
1638     ((stream standard-output-recording-stream) record)
1639     (add-output-record record (stream-current-output-record stream)))
1640    
1641     (defmethod stream-replay
1642     ((stream standard-output-recording-stream) &optional region)
1643     (replay (stream-output-history stream) stream region))
1644    
1645 adejneka 1.47 (defun output-record-ancestor-p (ancestor child)
1646     (loop for record = child then parent
1647     for parent = (output-record-parent record)
1648     when (eq parent nil) do (return nil)
1649     when (eq parent ancestor) do (return t)))
1650    
1651 adejneka 1.46 (defmethod erase-output-record (record (stream standard-output-recording-stream)
1652     &optional (errorp t))
1653     (letf (((stream-recording-p stream) nil))
1654     (let ((region (bounding-rectangle record)))
1655     (with-bounding-rectangle* (x1 y1 x2 y2) region
1656 adejneka 1.47 (if (output-record-ancestor-p (stream-output-history stream) record)
1657     (progn
1658     (delete-output-record record (output-record-parent record))
1659 adejneka 1.49 (with-output-recording-options (stream :record nil)
1660     (draw-rectangle* stream x1 y1 x2 y2 :ink +background-ink+))
1661 adejneka 1.47 (stream-replay stream region))
1662     (when errorp
1663     (error "~S is not contained in ~S." record stream)))))))
1664 adejneka 1.46
1665     (defun copy-textual-output-history (window stream &optional region record)
1666     ;; FIXME
1667     (declare (ignore window stream region record))
1668     (error "Not implemented."))
1669    
1670     ;;; 16.4.3. Text Output Recording
1671     (defmethod stream-text-output-record
1672     ((stream standard-output-recording-stream) text-style)
1673 mikemac 1.30 (declare (ignore text-style))
1674 adejneka 1.20 (let ((record (stream-current-text-output-record stream)))
1675 adejneka 1.47 (unless (and record (typep record 'standard-text-displayed-output-record))
1676     (multiple-value-bind (cx cy) (stream-cursor-position stream)
1677     (setf record (make-instance 'standard-text-displayed-output-record
1678     :x-position cx :y-position cy
1679 moore 1.57 :start-x cx :start-y cy
1680     :stream stream)
1681 adejneka 1.47 (stream-current-text-output-record stream) record)))
1682 adejneka 1.20 record))
1683    
1684 adejneka 1.46 (defmethod stream-close-text-output-record
1685     ((stream standard-output-recording-stream))
1686 adejneka 1.20 (let ((record (stream-current-text-output-record stream)))
1687     (when record
1688     (setf (stream-current-text-output-record stream) nil)
1689     #|record stream-current-cursor-position to (end-x record) - already done|#
1690     (stream-add-output-record stream record))))
1691    
1692 adejneka 1.46 (defmethod stream-add-character-output
1693     ((stream standard-output-recording-stream)
1694     character text-style width height baseline)
1695     (add-character-output-to-text-record
1696     (stream-text-output-record stream text-style)
1697     character text-style width height baseline))
1698 adejneka 1.20
1699 adejneka 1.22 (defmethod stream-add-string-output ((stream standard-output-recording-stream)
1700 adejneka 1.20 string start end text-style
1701     width height baseline)
1702 adejneka 1.46 (add-string-output-to-text-record (stream-text-output-record stream
1703     text-style)
1704 adejneka 1.20 string start end text-style
1705     width height baseline))
1706    
1707 adejneka 1.46 ;;; Text output catching methods
1708 adejneka 1.20 (defmacro without-local-recording (stream &body body)
1709 adejneka 1.22 `(letf (((slot-value ,stream 'local-record-p) nil))
1710 adejneka 1.47 ,@body))
1711 adejneka 1.22
1712 adejneka 1.46 (defmethod stream-write-line :around
1713     ((stream standard-output-recording-stream) line)
1714 adejneka 1.22 (when (and (stream-recording-p stream)
1715     (slot-value stream 'local-record-p))
1716     (let* ((medium (sheet-medium stream))
1717 adejneka 1.47 (text-style (medium-text-style medium))
1718     (*drawing-options* (list (medium-ink medium) ; XXX TDO
1719     (medium-clipping-region medium))))
1720 adejneka 1.22 (stream-add-string-output stream line 0 nil text-style
1721     (stream-string-width stream line
1722     :text-style text-style)
1723 strandh 1.26 (text-style-height text-style medium)
1724     (text-style-ascent text-style medium))))
1725 adejneka 1.22 (when (stream-drawing-p stream)
1726     (without-local-recording stream
1727     (call-next-method))))
1728 cvs 1.5
1729 adejneka 1.22 #+nil
1730     (defmethod stream-write-char :around ((stream standard-output-recording-stream) char)
1731 adejneka 1.20 (when (and (stream-recording-p stream)
1732     (slot-value stream 'local-record-p))
1733     (if (or (eql char #\return)
1734 moore 1.57
1735 adejneka 1.20 (stream-close-text-output-record stream)
1736 cvs 1.8 (let* ((medium (sheet-medium stream))
1737 strandh 1.26 (text-style (medium-text-style medium)))
1738 adejneka 1.20 (stream-add-character-output stream char text-style
1739     (stream-character-width stream char :text-style text-style)
1740 strandh 1.26 (text-style-height text-style medium)
1741     (text-style-ascent text-style medium)))))
1742 adejneka 1.20 (without-local-recording stream
1743 moore 1.57 (call-next-method))))
1744 adejneka 1.20
1745 adejneka 1.21 #+nil
1746 adejneka 1.22 (defmethod stream-write-string :around ((stream standard-output-recording-stream) string
1747 adejneka 1.20 &optional (start 0) end)
1748 adejneka 1.21 ;; Problem: it is necessary to check for line wrapping. Now the
1749     ;; default method for STREAM-WRITE-STRING do char-by-char output,
1750     ;; therefore STREAM-WRITE-CHAR can do the right thing.
1751 adejneka 1.20 (when (and (stream-recording-p stream)
1752     (slot-value stream 'local-record-p))
1753     (let* ((medium (sheet-medium stream))
1754 strandh 1.26 (text-style (medium-text-style medium)))
1755 adejneka 1.20 (stream-add-string-output stream string start end text-style
1756     (stream-string-width stream string
1757     :start start :end end
1758     :text-style text-style)
1759 strandh 1.26 (text-style-height text-style medium)
1760     (text-style-ascent text-style medium))))
1761 adejneka 1.20 (without-local-recording stream
1762     (call-next-method)))
1763 adejneka 1.41
1764 adejneka 1.20
1765 adejneka 1.22 (defmethod stream-finish-output :after ((stream standard-output-recording-stream))
1766 adejneka 1.20 (stream-close-text-output-record stream))
1767    
1768 adejneka 1.22 (defmethod stream-force-output :after ((stream standard-output-recording-stream))
1769 adejneka 1.20 (stream-close-text-output-record stream))
1770    
1771 adejneka 1.22 (defmethod stream-terpri :after ((stream standard-output-recording-stream))
1772 adejneka 1.21 (stream-close-text-output-record stream))
1773    
1774 rouanet 1.23 (defmethod* (setf stream-cursor-position) :after (x y (stream standard-output-recording-stream))
1775 mikemac 1.30 (declare (ignore x y))
1776 adejneka 1.20 (stream-close-text-output-record stream))
1777    
1778 adejneka 1.22 ;(defmethod stream-set-cursor-position :after ((stream standard-output-recording-stream))
1779 adejneka 1.20 ; (stream-close-text-output-record stream))
1780 cvs 1.5
1781 adejneka 1.22 (defmethod stream-wrap-line :before ((stream standard-output-recording-stream))
1782 cvs 1.5 (when (stream-recording-p stream)
1783 adejneka 1.20 (setf (text-record-wrapped (stream-text-output-record stream nil)) ; FIXME!
1784     (stream-text-margin stream))))
1785 adejneka 1.46
1786     ;;; 16.4.4. Output Recording Utilities
1787    
1788     (defmethod invoke-with-output-recording-options
1789     ((stream output-recording-stream) continuation record draw)
1790     "Calls CONTINUATION on STREAM enabling or disabling recording and drawing
1791     according to the flags RECORD and DRAW."
1792     (letf (((stream-recording-p stream) record)
1793     ((stream-drawing-p stream) draw))
1794     (funcall continuation stream)))
1795    
1796     (defmethod invoke-with-new-output-record ((stream output-recording-stream)
1797     continuation record-type
1798     &rest initargs
1799 adejneka 1.50 &key
1800 adejneka 1.46 &allow-other-keys)
1801     (stream-close-text-output-record stream)
1802 adejneka 1.47 (let ((new-record (apply #'make-instance record-type initargs)))
1803 adejneka 1.46 (letf (((stream-current-output-record stream) new-record))
1804     ;; Should we switch on recording? -- APD
1805     (funcall continuation stream new-record)
1806     (finish-output stream))
1807     (stream-add-output-record stream new-record)
1808     new-record))
1809    
1810     (defmethod invoke-with-output-to-output-record
1811     ((stream output-recording-stream) continuation record-type
1812     &rest initargs
1813 adejneka 1.50 &key
1814 adejneka 1.46 &allow-other-keys)
1815     (stream-close-text-output-record stream)
1816 adejneka 1.47 (let ((new-record (apply #'make-instance record-type initargs)))
1817 adejneka 1.46 (with-output-recording-options (stream :record t :draw nil)
1818 adejneka 1.48 (letf (((stream-current-output-record stream) new-record)
1819     ((stream-cursor-position stream) (values 0 0)))
1820     (funcall continuation stream new-record)
1821     (finish-output stream)))
1822 adejneka 1.46 new-record))
1823    
1824     (defmethod make-design-from-output-record (record)
1825     ;; FIXME
1826     (declare (ignore record))
1827     (error "Not implemented."))
1828    
1829    
1830     ;;; Additional methods
1831     (defmethod scroll-vertical :around ((stream output-recording-stream) dy)
1832     (declare (ignore dy))
1833     (with-output-recording-options (stream :record nil)
1834     (call-next-method)))
1835    
1836     (defmethod scroll-horizontal :around ((stream output-recording-stream) dx)
1837     (declare (ignore dx))
1838     (with-output-recording-options (stream :record nil)
1839     (call-next-method)))
1840    
1841     (defmethod handle-repaint ((stream output-recording-stream) region)
1842     (stream-replay stream region))
1843    

  ViewVC Help
Powered by ViewVC 1.1.5