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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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