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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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