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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.90 - (hide annotations)
Fri Sep 12 20:25:14 2003 UTC (10 years, 7 months ago) by hefner1
Branch: MAIN
Changes since 1.89: +25 -16 lines
stream-output.lisp:

* When moving the cursor as part of normal stream output, modify the cursor
  X/Y slots directly, rather than using the SETF method. This prevents the
  open output record from being needlessly broken.

recording.lisp:

* TEXT-DISPLAYED-OUTPUT-RECORD-STRING seems to have rotted, fixed it up.

* Fixed bug in RECOMPUTE-EXTENT-FOR-CHANGED-CHILD, bounding rectangles are
  now correctly recomputed when a child is deleted.
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     (list `(coord-seq
1141 hefner1 1.89 (transform-positions (medium-transformation medium)
1142     (if (vectorp coord-seq)
1143     coord-seq
1144     (coerce coord-seq 'vector)))))))
1145 gilbert 1.81 (make-instance ',class-name
1146     :stream stream
1147     ,@arg-list))))
1148 rouanet 1.11 (stream-add-output-record stream record)))
1149 cvs 1.5 (when (stream-drawing-p stream)
1150 adejneka 1.83 (,method-name medium ,@args))))
1151 mikemac 1.1 (defmethod replay-output-record ((record ,class-name) stream
1152 rouanet 1.18 &optional (region +everywhere+)
1153     (x-offset 0) (y-offset 0))
1154 moore 1.57 (declare (ignore x-offset y-offset region))
1155     (with-slots (,@args) record
1156     (let ((,medium (sheet-medium stream))
1157 adejneka 1.41 ;; is sheet a sheet-with-medium-mixin? --GB
1158     )
1159 moore 1.57 ;; Graphics state is set up in :around method.
1160     (,method-name ,medium ,@args)))))))
1161 mikemac 1.1
1162 moore 1.57 (def-grecording draw-point ((gs-line-style-mixin) point-x point-y)
1163     (let ((border (graphics-state-line-style-border graphic medium)))
1164     (with-transformed-position ((medium-transformation medium) point-x point-y)
1165     (setf (slot-value graphic 'point-x) point-x
1166     (slot-value graphic 'point-y) point-y)
1167     (values (- point-x border)
1168     (- point-y border)
1169     (+ point-x border)
1170     (+ point-y border)))))
1171    
1172     (defmethod* (setf output-record-position) :around
1173     (nx ny (record draw-point-output-record))
1174     (with-slots (x1 y1 point-x point-y)
1175     record
1176     (let ((dx (- nx x1))
1177     (dy (- ny y1)))
1178     (multiple-value-prog1
1179     (call-next-method)
1180     (incf point-x dx)
1181     (incf point-y dy)))))
1182    
1183 moore 1.64 (defrecord-predicate draw-point-output-record (point-x point-y)
1184 hefner1 1.84 (and (if-supplied (point-x coordinate)
1185 moore 1.64 (coordinate= (slot-value record 'point-x) point-x))
1186 hefner1 1.84 (if-supplied (point-y coordinate)
1187 moore 1.64 (coordinate= (slot-value record 'point-y) point-y))))
1188 moore 1.57
1189     (def-grecording draw-points ((coord-seq-mixin gs-line-style-mixin) coord-seq)
1190     ;; coord-seq has already been transformed
1191     (let ((border (graphics-state-line-style-border graphic medium)))
1192     (coord-seq-bounds coord-seq border)))
1193    
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     (let ((border (graphics-state-line-style-border graphic medium)))
1236     (coord-seq-bounds coord-seq border)))
1237    
1238 moore 1.64 ;;; (setf output-record-position) and predicates for draw-lines-output-record
1239     ;;; are taken care of by methods on superclasses.
1240    
1241 moore 1.57 ;;; Helper function
1242     (defun normalize-coords (dx dy &optional unit)
1243     (let ((norm (sqrt (+ (* dx dx) (* dy dy)))))
1244     (if unit
1245     (let ((scale (/ unit norm)))
1246     (values (* dx scale) (* dy scale)))
1247     (values (/ dx norm) (/ dy norm)))))
1248 mikemac 1.1
1249 adejneka 1.52 (defun polygon-record-bounding-rectangle
1250 moore 1.57 (coord-seq closed filled line-style border miter-limit)
1251 moore 1.54 (cond (filled
1252 moore 1.57 (coord-seq-bounds coord-seq 0))
1253 moore 1.54 ((eq (line-style-joint-shape line-style) :round)
1254 moore 1.57 (coord-seq-bounds coord-seq border))
1255     (t (let* ((x1 (svref coord-seq 0))
1256     (y1 (svref coord-seq 1))
1257     (min-x x1)
1258     (min-y y1)
1259     (max-x x1)
1260     (max-y y1)
1261     (len (length coord-seq)))
1262     (unless closed
1263     (setq min-x (- x1 border) min-y (- y1 border)
1264     max-x (+ x1 border) max-y (+ y1 border)))
1265     ;; Setup for iterating over the coordinate vector. If the polygon
1266     ;; is closed deal with the extra segment.
1267     (multiple-value-bind (initial-xp initial-yp
1268     final-xn final-yn
1269     initial-index final-index)
1270     (if closed
1271     (values (svref coord-seq (- len 2))
1272     (svref coord-seq (- len 1))
1273     x1 y1
1274     0 (- len 2))
1275     (values x1 y1
1276     (svref coord-seq (- len 2))
1277     (svref coord-seq (- len 1))
1278     2 (- len 4)))
1279     (ecase (line-style-joint-shape line-style)
1280     (:miter
1281     ;;FIXME: Remove successive positively proportional segments
1282     (loop with sin-limit = (sin (* 0.5 miter-limit))
1283     and xn and yn
1284     for i from initial-index to final-index by 2
1285     for xp = initial-xp then x
1286     for yp = initial-yp then y
1287     for x = (svref coord-seq i)
1288     for y = (svref coord-seq (1+ i))
1289     do (setf (values xn yn)
1290     (if (eql i final-index)
1291     (values final-xn final-yn)
1292     (values (svref coord-seq (+ i 2))
1293     (svref coord-seq (+ i
1294     3)))))
1295     (multiple-value-bind (ex1 ey1)
1296     (normalize-coords (- x xp) (- y yp))
1297     (multiple-value-bind (ex2 ey2)
1298     (normalize-coords (- x xn) (- y yn))
1299     (let* ((cos-a (+ (* ex1 ex2) (* ey1 ey2)))
1300     (sin-a/2 (sqrt (* 0.5 (- 1.0 cos-a)))))
1301     (if (< sin-a/2 sin-limit)
1302     (let ((nx (* border
1303     (max (abs ey1) (abs ey2))))
1304     (ny (* border
1305     (max (abs ex1) (abs ex2)))))
1306     (minf min-x (- x nx))
1307     (minf min-y (- y ny))
1308     (maxf max-x (+ x nx))
1309     (maxf max-y (+ y ny)))
1310     (let ((length (/ border sin-a/2)))
1311     (multiple-value-bind (dx dy)
1312     (normalize-coords (+ ex1 ex2)
1313     (+ ey1 ey2)
1314     length)
1315     (minf min-x (+ x dx))
1316     (minf min-y (+ y dy))
1317     (maxf max-x (+ x dx))
1318     (maxf max-y (+ y dy))))))))))
1319     ((:bevel :none)
1320     (loop with xn and yn
1321     for i from initial-index to final-index by 2
1322     for xp = initial-xp then x
1323     for yp = initial-yp then y
1324     for x = (svref coord-seq i)
1325     for y = (svref coord-seq (1+ i))
1326     do (setf (values xn yn)
1327     (if (eql i final-index)
1328     (values final-xn final-yn)
1329     (values (svref coord-seq (+ i 2))
1330     (svref coord-seq (+ i
1331     3)))))
1332     (multiple-value-bind (ex1 ey1)
1333     (normalize-coords (- x xp) (- y yp))
1334     (multiple-value-bind (ex2 ey2)
1335     (normalize-coords (- x xn) (- y yn))
1336     (let ((nx (* border (max (abs ey1) (abs ey2))))
1337     (ny (* border (max (abs ex1) (abs ex2)))))
1338     (minf min-x (- x nx))
1339     (minf min-y (- y ny))
1340     (maxf max-x (+ x nx))
1341     (maxf max-y (+ y ny))))))))
1342     (unless closed
1343     (multiple-value-bind (x y)
1344     (values (svref coord-seq final-index)
1345     (svref coord-seq (1+ final-index)))
1346     (minf min-x (- x border))
1347     (minf min-y (- y border))
1348     (maxf max-x (+ x border))
1349     (maxf max-y (+ y border)))))
1350     (values min-x min-y max-x max-y)))))
1351    
1352     (def-grecording draw-polygon ((coord-seq-mixin gs-line-style-mixin)
1353     coord-seq closed filled)
1354     (let ((border (graphics-state-line-style-border graphic medium)))
1355     (polygon-record-bounding-rectangle
1356     coord-seq closed filled line-style border (medium-miter-limit medium))))
1357    
1358 moore 1.64 (defrecord-predicate draw-polygon-output-record (closed filled)
1359 hefner1 1.84 (and (if-supplied (closed)
1360 moore 1.64 (eql (slot-value record 'closed) closed))
1361 hefner1 1.84 (if-supplied (filled)
1362 moore 1.64 (eql (slot-value record 'filled) filled))))
1363 moore 1.57
1364     (def-grecording draw-rectangle ((gs-line-style-mixin)
1365     left top right bottom filled)
1366     (let ((border (graphics-state-line-style-border graphic medium)))
1367     (polygon-record-bounding-rectangle
1368     (vector left top left bottom right bottom right top)
1369     t filled line-style border
1370     (medium-miter-limit medium))))
1371    
1372     (defmethod* (setf output-record-position) :around
1373     (nx ny (record draw-rectangle-output-record))
1374     (with-slots (x1 y1
1375     left top right bottom)
1376     record
1377     (let ((dx (- nx x1))
1378     (dy (- ny y1)))
1379     (multiple-value-prog1
1380     (call-next-method)
1381     (incf left dx)
1382     (incf top dy)
1383     (incf right dx)
1384     (incf bottom dy)))))
1385    
1386 moore 1.64 (defrecord-predicate draw-rectangle-output-record (left top right bottom filled)
1387 hefner1 1.84 (and (if-supplied (left coordinate)
1388 moore 1.64 (coordinate= (slot-value record 'left) left))
1389 hefner1 1.84 (if-supplied (top coordinate)
1390 moore 1.64 (coordinate= (slot-value record 'top) top))
1391 hefner1 1.84 (if-supplied (right coordinate)
1392 moore 1.64 (coordinate= (slot-value record 'right) right))
1393 hefner1 1.84 (if-supplied (bottom coordinate)
1394 moore 1.64 (coordinate= (slot-value record 'bottom) bottom))
1395 hefner1 1.84 (if-supplied (filled)
1396 moore 1.64 (eql (slot-value record 'filled) filled))))
1397 mikemac 1.1
1398 moore 1.57 (def-grecording draw-ellipse ((gs-line-style-mixin)
1399     center-x center-y
1400 mikemac 1.1 radius-1-dx radius-1-dy radius-2-dx radius-2-dy
1401     start-angle end-angle filled)
1402 adejneka 1.44 (multiple-value-bind (min-x min-y max-x max-y)
1403 moore 1.57 (bounding-rectangle* (make-ellipse* center-x center-y
1404     radius-1-dx radius-1-dy
1405     radius-2-dx radius-2-dy
1406     :start-angle start-angle
1407     :end-angle end-angle))
1408 adejneka 1.44 (if filled
1409     (values min-x min-y max-x max-y)
1410 moore 1.57 (let ((border (graphics-state-line-style-border graphic medium)))
1411     (values (- min-x border)
1412     (- min-y border)
1413     (+ max-x border)
1414     (+ max-y border))))))
1415    
1416     (defmethod* (setf output-record-position) :around
1417     (nx ny (record draw-ellipse-output-record))
1418     (with-slots (x1 y1 center-x center-y)
1419     record
1420     (let ((dx (- nx x1))
1421     (dy (- ny y1)))
1422     (multiple-value-prog1
1423     (call-next-method)
1424     (incf center-x dx)
1425     (incf center-y dy)))))
1426    
1427 moore 1.64 (defrecord-predicate draw-ellipse-output-record (center-x center-y)
1428 hefner1 1.84 (and (if-supplied (center-x coordinate)
1429     (coordinate= (slot-value record 'center-x) center-x))
1430     (if-supplied (center-y coordinate)
1431     (coordinate= (slot-value record 'center-y) center-y))))
1432 rouanet 1.11
1433 gilbert 1.88 ;;;; Patterns
1434    
1435     (def-grecording draw-pattern (() pattern x y)
1436     (let ((width (pattern-width pattern))
1437     (height (pattern-height pattern)))
1438     (values x y (+ x width) (+ y height))))
1439    
1440     (defmethod* (setf output-record-position) :around (nx ny (record draw-pattern-output-record))
1441     (with-slots (x1 y1 x y)
1442     record
1443     (let ((dx (- nx x1))
1444     (dy (- ny y1)))
1445     (multiple-value-prog1
1446     (call-next-method)
1447     (incf x dx)
1448     (incf y dy)))))
1449    
1450     (defrecord-predicate draw-pattern-output-record (x y pattern)
1451     ;; ### I am not so sure about the correct usage of DEFRECORD-PREDICATE
1452     ;; --GB 2003-08-15
1453     (and (if-supplied (x coordinate)
1454     (coordinate= (slot-value record 'x) x))
1455     (if-supplied (y coordinate)
1456     (coordinate= (slot-value record 'y) y))
1457     (if-supplied (pattern pattern)
1458     (eq (slot-value record 'pattern) pattern))))
1459    
1460     ;;;; Text
1461    
1462 moore 1.57 (def-grecording draw-text ((gs-text-style-mixin) string point-x point-y start end
1463 rouanet 1.11 align-x align-y toward-x toward-y transform-glyphs)
1464 adejneka 1.44 ;; FIXME!!! Text direction.
1465 adejneka 1.43 ;; Multiple lines?
1466 moore 1.57 (let* ((text-style (graphics-state-text-style graphic))
1467 moore 1.67 (width (if (characterp string)
1468     (stream-character-width stream string :text-style text-style)
1469     (stream-string-width stream string
1470     :start start :end end
1471     :text-style text-style)) )
1472 strandh 1.26 (ascent (text-style-ascent text-style (sheet-medium stream)))
1473     (descent (text-style-descent text-style (sheet-medium stream)))
1474 rouanet 1.11 (height (+ ascent descent))
1475     left top right bottom)
1476     (ecase align-x
1477     (:left (setq left point-x
1478     right (+ point-x width)))
1479     (:right (setq left (- point-x width)
1480     right point-x))
1481     (:center (setq left (- point-x (round width 2))
1482     right (+ point-x (round width 2)))))
1483     (ecase align-y
1484 adejneka 1.43 (:baseline (setq top (- point-y ascent)
1485 rouanet 1.11 bottom (+ point-y descent)))
1486     (:top (setq top point-y
1487     bottom (+ point-y height)))
1488     (:bottom (setq top (- point-y height)
1489     bottom point-y))
1490     (:center (setq top (- point-y (floor height 2))
1491     bottom (+ point-y (ceiling height 2)))))
1492     (values left top right bottom)))
1493 mikemac 1.1
1494 moore 1.57 (defmethod* (setf output-record-position) :around
1495     (nx ny (record draw-text-output-record))
1496     (with-slots (x1 y1 point-x point-y toward-x toward-y)
1497     record
1498     (let ((dx (- nx x1))
1499     (dy (- ny y1)))
1500     (multiple-value-prog1
1501     (call-next-method)
1502     (incf point-x dx)
1503     (incf point-y dy)
1504     (incf toward-x dx)
1505     (incf toward-y dy)))))
1506    
1507 moore 1.64 (defrecord-predicate draw-text-output-record
1508     (string start end point-x point-y align-x align-y toward-x toward-y
1509     transform-glyphs)
1510 hefner1 1.84 (and (if-supplied (string)
1511 moore 1.64 (string= (slot-value record 'string) string))
1512 hefner1 1.84 (if-supplied (start)
1513 moore 1.64 (eql (slot-value record 'start) start))
1514 hefner1 1.84 (if-supplied (end)
1515 moore 1.64 (eql (slot-value record 'end) end))
1516 hefner1 1.84 (if-supplied (point-x coordinate)
1517 moore 1.64 (coordinate= (slot-value record 'point-x) point-x))
1518 hefner1 1.84 (if-supplied (point-y coordinate)
1519 moore 1.64 (coordinate= (slot-value record 'point-y) point-y))
1520 hefner1 1.84 (if-supplied (align-x)
1521 moore 1.64 (eq (slot-value record 'align-x) align-x))
1522 hefner1 1.84 (if-supplied (align-y)
1523 moore 1.64 (eq (slot-value record 'align-y) align-y))
1524 hefner1 1.84 (if-supplied (toward-x coordinate)
1525 moore 1.64 (coordinate= (slot-value record 'toward-x) toward-x))
1526 hefner1 1.84 (if-supplied (toward-y coordinate)
1527 moore 1.64 (coordinate= (slot-value record 'toward-y) toward-y))
1528 hefner1 1.84 (if-supplied (transform-glyphs)
1529 moore 1.64 (eq (slot-value record 'transform-glyphs) transform-glyphs))))
1530 moore 1.57
1531 adejneka 1.46 ;;; 16.3.3. Text Displayed Output Record
1532 adejneka 1.47
1533 moore 1.57 (defclass styled-string (gs-text-style-mixin gs-clip-mixin gs-ink-mixin)
1534 adejneka 1.47 ((start-x :initarg :start-x)
1535     (string :initarg :string :reader styled-string-string)))
1536 moore 1.34
1537 moore 1.64 (defmethod output-record-equal and ((record styled-string)
1538     (record2 styled-string))
1539     (and (coordinate= (slot-value record 'start-x)
1540     (slot-value record2 'start-x))
1541     (string= (slot-value record 'string)
1542     (slot-value record2 'string))))
1543    
1544 adejneka 1.46 (defclass standard-text-displayed-output-record
1545     (text-displayed-output-record standard-displayed-output-record)
1546 adejneka 1.47 ((initial-x1 :initarg :start-x)
1547     (initial-y1 :initarg :start-y)
1548     (strings :initform nil)
1549 mikemac 1.1 (baseline :initform 0)
1550 adejneka 1.22 (width :initform 0)
1551 mikemac 1.1 (max-height :initform 0)
1552 cvs 1.6 (start-x :initarg :start-x)
1553     (start-y :initarg :start-y)
1554 adejneka 1.47 (end-x :initarg :start-x)
1555     (end-y :initarg :start-y)
1556 cvs 1.8 (wrapped :initform nil
1557 moore 1.57 :accessor text-record-wrapped)
1558     (medium :initarg :medium :initform nil)))
1559    
1560     (defmethod initialize-instance :after
1561     ((obj standard-text-displayed-output-record) &key stream)
1562     (when stream
1563     (setf (slot-value obj 'medium) (sheet-medium stream))))
1564 mikemac 1.1
1565 moore 1.64 ;;; Forget match-output-records-1 for standard-text-displayed-output-record; it
1566     ;;; doesn't make much sense because these records have state that is not
1567     ;;; initialized via initargs.
1568    
1569     (defmethod output-record-equal and
1570     ((record standard-text-displayed-output-record)
1571     (record2 standard-text-displayed-output-record))
1572     (with-slots
1573     (initial-x1 initial-y1 start-x start-y end-x end-y wrapped strings)
1574     record2
1575     (and (coordinate= (slot-value record 'initial-x1) initial-x1)
1576     (coordinate= (slot-value record 'initial-y1) initial-y1)
1577     (coordinate= (slot-value record 'start-x) start-x)
1578     (coordinate= (slot-value record 'start-y) start-y)
1579     (coordinate= (slot-value record 'end-x) end-x)
1580     (coordinate= (slot-value record 'end-y) end-y)
1581     (eq (slot-value record 'wrapped) wrapped)
1582     (coordinate= (slot-value record 'baseline)
1583     (slot-value record2 'baseline))
1584     (eql (length (slot-value record 'strings)) (length strings));XXX
1585     (loop for s1 in (slot-value record 'strings)
1586     for s2 in strings
1587 mikemac 1.65 always (output-record-equal s1 s2)))))
1588 moore 1.64
1589 adejneka 1.46 (defmethod print-object ((self standard-text-displayed-output-record) stream)
1590 cvs 1.8 (print-unreadable-object (self stream :type t :identity t)
1591 adejneka 1.47 (with-slots (start-x start-y strings) self
1592     (format stream "~D,~D ~S"
1593     start-x start-y
1594     (mapcar #'styled-string-string strings)))))
1595 mikemac 1.1
1596 moore 1.34 (defmethod* (setf output-record-position) :before
1597 adejneka 1.46 (nx ny (record standard-text-displayed-output-record))
1598 moore 1.57 (with-slots (x1 y1 start-x start-y end-x end-y strings) record
1599 adejneka 1.46 (let ((dx (- nx x1))
1600     (dy (- ny y1)))
1601 rouanet 1.23 (incf start-x dx)
1602     (incf start-y dy)
1603     (incf end-x dx)
1604 moore 1.57 (incf end-y dy)
1605     (loop for s in strings
1606     do (incf (slot-value s 'start-x) dx)))))
1607 cvs 1.9
1608 adejneka 1.46 (defmethod replay-output-record ((record standard-text-displayed-output-record)
1609 moore 1.34 stream
1610 adejneka 1.21 &optional region (x-offset 0) (y-offset 0))
1611 adejneka 1.46 (declare (ignore region x-offset y-offset))
1612 moore 1.57 (with-slots (strings baseline max-height start-y wrapped x1 y1)
1613     record
1614 adejneka 1.47 (with-sheet-medium (medium stream) ;is sheet a sheet-with-medium-mixin? --GB
1615 moore 1.57 ;; FIXME:
1616     ;; 1. SLOT-VALUE...
1617     ;; 2. It should also save a "current line".
1618     (setf (slot-value stream 'baseline) baseline)
1619     (loop for substring in strings
1620     do (with-slots (start-x string)
1621     substring
1622     (setf (stream-cursor-position stream)
1623     (values start-x start-y))
1624     (set-medium-graphics-state substring medium)
1625 moore 1.67 (stream-write-output stream string)))
1626 moore 1.57 (when wrapped ; FIXME
1627     (draw-rectangle* medium
1628     (+ wrapped 0) start-y
1629     (+ wrapped 4) (+ start-y max-height)
1630     :ink +foreground-ink+
1631     :filled t)))))
1632 mikemac 1.1
1633 moore 1.34 (defmethod output-record-start-cursor-position
1634 adejneka 1.46 ((record standard-text-displayed-output-record))
1635 mikemac 1.1 (with-slots (start-x start-y) record
1636     (values start-x start-y)))
1637    
1638 moore 1.34 (defmethod output-record-end-cursor-position
1639 adejneka 1.46 ((record standard-text-displayed-output-record))
1640 mikemac 1.1 (with-slots (end-x end-y) record
1641     (values end-x end-y)))
1642    
1643 adejneka 1.46 (defmethod tree-recompute-extent
1644     ((text-record standard-text-displayed-output-record))
1645     (with-slots (parent x1 y1 x2 y2 width max-height) text-record
1646     (setq x2 (coordinate (+ x1 width))
1647 adejneka 1.47 y2 (coordinate (+ y1 max-height))))
1648     text-record)
1649 adejneka 1.46
1650 adejneka 1.47 (defmethod add-character-output-to-text-record ; XXX OAOO with ADD-STRING-...
1651 adejneka 1.46 ((text-record standard-text-displayed-output-record)
1652     character text-style char-width height new-baseline)
1653 moore 1.57 (with-slots (strings baseline width max-height start-y end-x end-y medium)
1654     text-record
1655     (if (and strings
1656     (let ((string (last1 strings)))
1657     (match-output-records string
1658     :text-style text-style
1659     :ink (medium-ink medium)
1660     :clipping-region (medium-clipping-region
1661     medium))))
1662     (vector-push-extend character (slot-value (last1 strings) 'string))
1663     (nconcf strings
1664     (list (make-instance
1665     'styled-string
1666     :start-x end-x
1667     :text-style text-style
1668     :medium medium ; pick up ink and clipping region
1669     :string (make-array 1 :initial-element character
1670     :element-type 'character
1671     :adjustable t
1672     :fill-pointer t)))))
1673     (setq baseline (max baseline new-baseline)
1674     end-x (+ end-x char-width)
1675     max-height (max max-height height)
1676     end-y (max end-y (+ start-y max-height))
1677     width (+ width char-width)))
1678 adejneka 1.46 (tree-recompute-extent text-record))
1679    
1680     (defmethod add-string-output-to-text-record
1681     ((text-record standard-text-displayed-output-record)
1682     string start end text-style string-width height new-baseline)
1683 hefner1 1.69 (setf end (or end (length string)))
1684 adejneka 1.46 (let ((length (max 0 (- end start))))
1685     (cond
1686 moore 1.57 ((eql length 1)
1687 adejneka 1.47 (add-character-output-to-text-record text-record
1688     (aref string start)
1689     text-style
1690     string-width height new-baseline))
1691 moore 1.57 (t (with-slots (strings baseline width max-height start-y end-x end-y
1692     medium)
1693     text-record
1694     (let ((styled-string (make-instance
1695     'styled-string
1696     :start-x end-x
1697     :text-style text-style
1698     :medium medium
1699 hefner1 1.69 :string (make-array length
1700 moore 1.57 :element-type 'character
1701     :adjustable t
1702     :fill-pointer t))))
1703     (nconcf strings (list styled-string))
1704     (replace (styled-string-string styled-string) string
1705     :start2 start :end2 end))
1706     (setq baseline (max baseline new-baseline)
1707     end-x (+ end-x string-width)
1708     max-height (max max-height height)
1709     end-y (max end-y (+ start-y max-height))
1710     width (+ width string-width)))
1711 adejneka 1.47 (tree-recompute-extent text-record)))))
1712 adejneka 1.46
1713 moore 1.34 (defmethod text-displayed-output-record-string
1714 adejneka 1.46 ((record standard-text-displayed-output-record))
1715 hefner1 1.90 (with-slots (strings) record
1716     (if (= 1 (length strings))
1717     (styled-string-string (first strings))
1718     (with-output-to-string (result)
1719     (loop for styled-string in strings
1720     do (write-string (styled-string-string styled-string) result))))))
1721 adejneka 1.46
1722     ;;; 16.3.4. Top-Level Output Records
1723     (defclass stream-output-history-mixin ()
1724     ())
1725    
1726     (defclass standard-sequence-output-history
1727     (standard-sequence-output-record stream-output-history-mixin)
1728     ())
1729 cvs 1.5
1730 adejneka 1.46 (defclass standard-tree-output-history
1731     (standard-tree-output-record stream-output-history-mixin)
1732 moore 1.34 ())
1733    
1734 adejneka 1.46 ;;; 16.4. Output Recording Streams
1735     (defclass standard-output-recording-stream (output-recording-stream)
1736     ((recording-p :initform t :reader stream-recording-p)
1737     (drawing-p :initform t :accessor stream-drawing-p)
1738     (output-history :initform (make-instance 'standard-tree-output-history)
1739     :reader stream-output-history)
1740     (current-output-record :accessor stream-current-output-record)
1741     (current-text-output-record :initform nil
1742     :accessor stream-current-text-output-record)
1743     (local-record-p :initform t
1744     :documentation "This flag is used for dealing with streams outputting strings char-by-char.")))
1745    
1746     (defmethod initialize-instance :after
1747     ((stream standard-output-recording-stream) &rest args)
1748     (declare (ignore args))
1749     (setf (stream-current-output-record stream) (stream-output-history stream)))
1750    
1751 moore 1.55 ;;; Used in initializing clim-stream-pane
1752    
1753     (defmethod reset-output-history ((stream
1754     standard-output-recording-stream))
1755     (setf (slot-value stream 'output-history)
1756     (make-instance 'standard-tree-output-history))
1757     (setf (stream-current-output-record stream) (stream-output-history stream)))
1758    
1759 adejneka 1.46 ;;; 16.4.1 The Output Recording Stream Protocol
1760     (defmethod (setf stream-recording-p)
1761     (recording-p (stream standard-output-recording-stream))
1762     (let ((old-val (slot-value stream 'recording-p)))
1763     (setf (slot-value stream 'recording-p) recording-p)
1764     (when (not (eq old-val recording-p))
1765     (stream-close-text-output-record stream))
1766     recording-p))
1767    
1768     (defmethod stream-add-output-record
1769     ((stream standard-output-recording-stream) record)
1770     (add-output-record record (stream-current-output-record stream)))
1771    
1772     (defmethod stream-replay
1773     ((stream standard-output-recording-stream) &optional region)
1774     (replay (stream-output-history stream) stream region))
1775    
1776 adejneka 1.47 (defun output-record-ancestor-p (ancestor child)
1777     (loop for record = child then parent
1778     for parent = (output-record-parent record)
1779     when (eq parent nil) do (return nil)
1780     when (eq parent ancestor) do (return t)))
1781    
1782 adejneka 1.46 (defmethod erase-output-record (record (stream standard-output-recording-stream)
1783     &optional (errorp t))
1784     (letf (((stream-recording-p stream) nil))
1785     (let ((region (bounding-rectangle record)))
1786     (with-bounding-rectangle* (x1 y1 x2 y2) region
1787 adejneka 1.47 (if (output-record-ancestor-p (stream-output-history stream) record)
1788     (progn
1789     (delete-output-record record (output-record-parent record))
1790 adejneka 1.49 (with-output-recording-options (stream :record nil)
1791     (draw-rectangle* stream x1 y1 x2 y2 :ink +background-ink+))
1792 adejneka 1.47 (stream-replay stream region))
1793     (when errorp
1794     (error "~S is not contained in ~S." record stream)))))))
1795 adejneka 1.46
1796     ;;; 16.4.3. Text Output Recording
1797     (defmethod stream-text-output-record
1798     ((stream standard-output-recording-stream) text-style)
1799 mikemac 1.30 (declare (ignore text-style))
1800 adejneka 1.20 (let ((record (stream-current-text-output-record stream)))
1801 adejneka 1.47 (unless (and record (typep record 'standard-text-displayed-output-record))
1802     (multiple-value-bind (cx cy) (stream-cursor-position stream)
1803     (setf record (make-instance 'standard-text-displayed-output-record
1804     :x-position cx :y-position cy
1805 moore 1.57 :start-x cx :start-y cy
1806     :stream stream)
1807 adejneka 1.47 (stream-current-text-output-record stream) record)))
1808 adejneka 1.20 record))
1809    
1810 adejneka 1.46 (defmethod stream-close-text-output-record
1811     ((stream standard-output-recording-stream))
1812 adejneka 1.20 (let ((record (stream-current-text-output-record stream)))
1813     (when record
1814     (setf (stream-current-text-output-record stream) nil)
1815     #|record stream-current-cursor-position to (end-x record) - already done|#
1816     (stream-add-output-record stream record))))
1817    
1818 adejneka 1.46 (defmethod stream-add-character-output
1819     ((stream standard-output-recording-stream)
1820     character text-style width height baseline)
1821     (add-character-output-to-text-record
1822     (stream-text-output-record stream text-style)
1823     character text-style width height baseline))
1824 adejneka 1.20
1825 adejneka 1.22 (defmethod stream-add-string-output ((stream standard-output-recording-stream)
1826 adejneka 1.20 string start end text-style
1827     width height baseline)
1828 adejneka 1.46 (add-string-output-to-text-record (stream-text-output-record stream
1829     text-style)
1830 adejneka 1.20 string start end text-style
1831     width height baseline))
1832    
1833 adejneka 1.46 ;;; Text output catching methods
1834 adejneka 1.20 (defmacro without-local-recording (stream &body body)
1835 adejneka 1.22 `(letf (((slot-value ,stream 'local-record-p) nil))
1836 adejneka 1.47 ,@body))
1837 adejneka 1.22
1838 moore 1.67 (defmethod stream-write-output :around
1839 hefner1 1.69 ((stream standard-output-recording-stream) line
1840     &optional (start 0) end)
1841 adejneka 1.22 (when (and (stream-recording-p stream)
1842     (slot-value stream 'local-record-p))
1843     (let* ((medium (sheet-medium stream))
1844 moore 1.67 (text-style (medium-text-style medium))
1845     (height (text-style-height text-style medium))
1846     (ascent (text-style-ascent text-style medium)))
1847     (if (characterp line)
1848     (stream-add-character-output stream line text-style
1849     (stream-character-width
1850     stream line :text-style text-style)
1851     height
1852     ascent)
1853 hefner1 1.69 (stream-add-string-output stream line start end text-style
1854 moore 1.67 (stream-string-width stream line
1855 hefner1 1.69 :start start :end end
1856 moore 1.67 :text-style text-style)
1857 hefner1 1.69
1858 moore 1.67 height
1859     ascent))))
1860 adejneka 1.22 (when (stream-drawing-p stream)
1861     (without-local-recording stream
1862     (call-next-method))))
1863 cvs 1.5
1864 adejneka 1.22 #+nil
1865     (defmethod stream-write-char :around ((stream standard-output-recording-stream) char)
1866 adejneka 1.20 (when (and (stream-recording-p stream)
1867     (slot-value stream 'local-record-p))
1868     (if (or (eql char #\return)
1869 moore 1.57
1870 adejneka 1.20 (stream-close-text-output-record stream)
1871 cvs 1.8 (let* ((medium (sheet-medium stream))
1872 strandh 1.26 (text-style (medium-text-style medium)))
1873 adejneka 1.20 (stream-add-character-output stream char text-style
1874     (stream-character-width stream char :text-style text-style)
1875 strandh 1.26 (text-style-height text-style medium)
1876     (text-style-ascent text-style medium)))))
1877 adejneka 1.20 (without-local-recording stream
1878 moore 1.57 (call-next-method))))
1879 adejneka 1.20
1880 adejneka 1.21 #+nil
1881 adejneka 1.22 (defmethod stream-write-string :around ((stream standard-output-recording-stream) string
1882 adejneka 1.20 &optional (start 0) end)
1883     (when (and (stream-recording-p stream)
1884     (slot-value stream 'local-record-p))
1885     (let* ((medium (sheet-medium stream))
1886 strandh 1.26 (text-style (medium-text-style medium)))
1887 adejneka 1.20 (stream-add-string-output stream string start end text-style
1888     (stream-string-width stream string
1889     :start start :end end
1890     :text-style text-style)
1891 strandh 1.26 (text-style-height text-style medium)
1892     (text-style-ascent text-style medium))))
1893 adejneka 1.20 (without-local-recording stream
1894     (call-next-method)))
1895 adejneka 1.41
1896 adejneka 1.20
1897 adejneka 1.22 (defmethod stream-finish-output :after ((stream standard-output-recording-stream))
1898 adejneka 1.20 (stream-close-text-output-record stream))
1899    
1900 adejneka 1.22 (defmethod stream-force-output :after ((stream standard-output-recording-stream))
1901 adejneka 1.20 (stream-close-text-output-record stream))
1902    
1903 adejneka 1.22 (defmethod stream-terpri :after ((stream standard-output-recording-stream))
1904 adejneka 1.21 (stream-close-text-output-record stream))
1905    
1906 rouanet 1.23 (defmethod* (setf stream-cursor-position) :after (x y (stream standard-output-recording-stream))
1907 hefner1 1.66 (declare (ignore x y))
1908 moore 1.68 (stream-close-text-output-record stream))
1909 adejneka 1.20
1910 adejneka 1.22 ;(defmethod stream-set-cursor-position :after ((stream standard-output-recording-stream))
1911 adejneka 1.20 ; (stream-close-text-output-record stream))
1912 cvs 1.5
1913 adejneka 1.22 (defmethod stream-wrap-line :before ((stream standard-output-recording-stream))
1914 cvs 1.5 (when (stream-recording-p stream)
1915 adejneka 1.20 (setf (text-record-wrapped (stream-text-output-record stream nil)) ; FIXME!
1916     (stream-text-margin stream))))
1917 adejneka 1.46
1918     ;;; 16.4.4. Output Recording Utilities
1919    
1920     (defmethod invoke-with-output-recording-options
1921     ((stream output-recording-stream) continuation record draw)
1922     "Calls CONTINUATION on STREAM enabling or disabling recording and drawing
1923     according to the flags RECORD and DRAW."
1924     (letf (((stream-recording-p stream) record)
1925     ((stream-drawing-p stream) draw))
1926     (funcall continuation stream)))
1927    
1928     (defmethod invoke-with-new-output-record ((stream output-recording-stream)
1929     continuation record-type
1930     &rest initargs
1931 adejneka 1.50 &key
1932 adejneka 1.46 &allow-other-keys)
1933     (stream-close-text-output-record stream)
1934 adejneka 1.47 (let ((new-record (apply #'make-instance record-type initargs)))
1935 hefner1 1.78 (stream-add-output-record stream new-record)
1936 adejneka 1.46 (letf (((stream-current-output-record stream) new-record))
1937     ;; Should we switch on recording? -- APD
1938     (funcall continuation stream new-record)
1939     (finish-output stream))
1940     new-record))
1941    
1942     (defmethod invoke-with-output-to-output-record
1943     ((stream output-recording-stream) continuation record-type
1944     &rest initargs
1945 adejneka 1.50 &key
1946 adejneka 1.46 &allow-other-keys)
1947     (stream-close-text-output-record stream)
1948 adejneka 1.47 (let ((new-record (apply #'make-instance record-type initargs)))
1949 adejneka 1.46 (with-output-recording-options (stream :record t :draw nil)
1950 adejneka 1.48 (letf (((stream-current-output-record stream) new-record)
1951     ((stream-cursor-position stream) (values 0 0)))
1952     (funcall continuation stream new-record)
1953     (finish-output stream)))
1954 adejneka 1.46 new-record))
1955    
1956     (defmethod make-design-from-output-record (record)
1957     ;; FIXME
1958     (declare (ignore record))
1959     (error "Not implemented."))
1960    
1961    
1962     ;;; Additional methods
1963     (defmethod scroll-vertical :around ((stream output-recording-stream) dy)
1964     (declare (ignore dy))
1965     (with-output-recording-options (stream :record nil)
1966     (call-next-method)))
1967    
1968     (defmethod scroll-horizontal :around ((stream output-recording-stream) dx)
1969     (declare (ignore dx))
1970     (with-output-recording-options (stream :record nil)
1971     (call-next-method)))
1972    
1973     (defmethod handle-repaint ((stream output-recording-stream) region)
1974 hefner1 1.76 ;; FIXME: Change things so the rectangle below is only drawn in response
1975 gilbert 1.77 ;; to explicit repaint requests from the user