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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.138 - (hide annotations)
Sat Feb 2 19:03:00 2008 UTC (6 years, 2 months ago) by thenriksen
Branch: MAIN
Changes since 1.137: +4 -2 lines
Output recording bandaids:

Use CLIM 2.2 region default for replay.

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