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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.134 - (hide annotations)
Wed Jul 18 16:31:27 2007 UTC (6 years, 9 months ago) by rstrandh
Branch: MAIN
CVS Tags: McCLIM-0-9-5
Changes since 1.133: +4 -1 lines
Added IGNORE declarations to avoid warnings about unused variables.
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.132 ;; If record is currently empty, use the child's bbox directly. Else..
783     ;; Does the new rectangle of the child contain the original rectangle?
784     ;; If so, we can use min/max to grow record's current rectangle.
785     ;; If not, the child has shrunk, and we need to fully recompute.
786     (multiple-value-bind (nx1 ny1 nx2 ny2)
787     (cond
788     ;; The child has been deleted; who knows what the
789     ;; new bounding box might be.
790     ((not (output-record-parent changed-child))
791     (%tree-recompute-extent* record))
792     ;; Only one child of record, and we already have the bounds.
793     ((eql (output-record-count record) 1)
794     (values cx1 cy1 cx2 cy2))
795     ;; If our record occupied no space (had no children, or had only
796     ;; children similarly occupying no space, hackishly determined by
797     ;; null-bounding-rectangle-p), recompute the extent now, otherwise
798     ;; the next COND clause would, as an optimization, attempt to extend
799     ;; our current bounding rectangle, which is invalid.
800     ((null-bounding-rectangle-p record)
801     (%tree-recompute-extent* record))
802     ;; In the following cases, we can grow the new bounding rectangle
803     ;; from its previous state:
804     ((or
805     ;; If the child was originally empty, it should not have affected
806     ;; previous computation of our bounding rectangle.
807     ;; This is hackish for reasons similar to the above.
808     (and (zerop old-min-x) (zerop old-min-y)
809     (zerop old-max-x) (zerop old-max-y))
810     ;; For each old child coordinate, either it was not
811     ;; involved in determining the bounding rectangle of the
812     ;; parent, or else it is the same as the corresponding
813     ;; new child coordinate.
814     (and (or (> old-min-x ox1) (= old-min-x cx1))
815     (or (> old-min-y oy1) (= old-min-y cy1))
816     (or (< old-max-x ox2) (= old-max-x cx2))
817     (or (< old-max-y oy2) (= old-max-y cy2)))
818     ;; New child bounds contain old child bounds, so use min/max
819     ;; to extend the already-calculated rectangle.
820     (and (<= cx1 old-min-x) (<= cy1 old-min-y)
821     (>= cx2 old-max-x) (>= cy2 old-max-y)))
822     (values (min cx1 ox1) (min cy1 oy1)
823     (max cx2 ox2) (max cy2 oy2)))
824     ;; No shortcuts - we must compute a new bounding box from those of
825     ;; all our children. We want to avoid this - in worst cases, such as
826     ;; a toplevel output history, large graph, or table, there may exist
827     ;; thousands of children. Without the above optimizations,
828     ;; construction becomes O(N^2) due to bounding rectangle calculation.
829     (t (%tree-recompute-extent* record)))
830     ;; XXX banish x, y
831     (with-slots (x y)
832     record
833     (setf x nx1 y ny1)
834     (setf (rectangle-edges* record) (values nx1 ny1 nx2 ny2))
835     (let ((parent (output-record-parent record)))
836     (unless (or (null parent)
837     (and (= nx1 ox1) (= ny1 oy1)
838     (= nx2 ox2) (= nx2 oy2)))
839     (recompute-extent-for-changed-child parent record
840     ox1 oy1 ox2 oy2)))))))
841 adejneka 1.47 record)
842 moore 1.34
843 hefner1 1.86 ;; There was once an :around method on recompute-extent-for-changed-child here,
844     ;; but I've eliminated it. Its function was to notify the parent OR in case
845     ;; the bounding rect here changed - I've merged this into the above method.
846     ;; --Hefner, 8/7/02
847 adejneka 1.46
848     (defmethod tree-recompute-extent ((record compound-output-record))
849 moore 1.99 (tree-recompute-extent-aux record)
850 adejneka 1.47 record)
851 mikemac 1.1
852 adejneka 1.46 (defmethod tree-recompute-extent :around ((record compound-output-record))
853 moore 1.99 (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2)
854     record
855 adejneka 1.22 (call-next-method)
856 moore 1.99 (with-bounding-rectangle* (x1 y1 x2 y2)
857     record
858     (let ((parent (output-record-parent record)))
859     (when (and parent
860     (not (and (= old-x1 x1)
861     (= old-y1 y1)
862     (= old-x2 x2)
863     (= old-y2 y2))))
864     (recompute-extent-for-changed-child parent record
865     old-x1 old-y1
866     old-x2 old-y2)))))
867 adejneka 1.47 record)
868 mikemac 1.1
869 adejneka 1.46 ;;; 16.3.1. Standard output record classes
870 mikemac 1.1
871 adejneka 1.46 (defclass standard-sequence-output-record (compound-output-record)
872     ((children :initform (make-array 8 :adjustable t :fill-pointer 0)
873     :reader output-record-children)))
874 moore 1.34
875 adejneka 1.46 (defmethod add-output-record (child (record standard-sequence-output-record))
876 adejneka 1.47 (vector-push-extend child (output-record-children record))
877     (setf (output-record-parent child) record))
878 mikemac 1.1
879 adejneka 1.46 (defmethod delete-output-record (child (record standard-sequence-output-record)
880     &optional (errorp t))
881     (with-slots (children) record
882     (let ((pos (position child children :test #'eq)))
883     (if (null pos)
884 hefner1 1.90 (when errorp
885     (error "~S is not a child of ~S" child record))
886     (progn
887     (setq children (replace children children
888     :start1 pos
889     :start2 (1+ pos)))
890     (decf (fill-pointer children))
891     (setf (output-record-parent child) nil))))))
892 mikemac 1.1
893 adejneka 1.46 (defmethod clear-output-record ((record standard-sequence-output-record))
894 adejneka 1.47 (let ((children (output-record-children record)))
895     (map 'nil (lambda (child) (setf (output-record-parent child) nil))
896     children)
897 adejneka 1.46 (fill children nil)
898     (setf (fill-pointer children) 0)))
899 rouanet 1.11
900 adejneka 1.46 (defmethod output-record-count ((record standard-sequence-output-record))
901     (length (output-record-children record)))
902 rouanet 1.11
903 tmoore 1.117 (defmethod map-over-output-records-1
904     (function (record standard-sequence-output-record) function-args)
905 adejneka 1.46 "Applies FUNCTION to all children in the order they were added."
906 tmoore 1.117 (if function-args
907     (loop with children = (output-record-children record)
908     for child across children
909     do (apply function child function-args))
910     (loop with children = (output-record-children record)
911     for child across children
912     do (funcall function child))))
913    
914 adejneka 1.46 (defmethod map-over-output-records-containing-position
915     (function (record standard-sequence-output-record) x y
916     &optional (x-offset 0) (y-offset 0)
917     &rest function-args)
918     "Applies FUNCTION to children, containing (X,Y), in the reversed
919     order they were added."
920     (declare (ignore x-offset y-offset))
921     (loop with children = (output-record-children record)
922     for i from (1- (length children)) downto 0
923     for child = (aref children i)
924     when (and (multiple-value-bind (min-x min-y max-x max-y)
925     (output-record-hit-detection-rectangle* child)
926     (and (<= min-x x max-x) (<= min-y y max-y)))
927     (output-record-refined-position-test child x y))
928     do (apply function child function-args)))
929 cvs 1.7
930 adejneka 1.46 (defmethod map-over-output-records-overlapping-region
931     (function (record standard-sequence-output-record) region
932     &optional (x-offset 0) (y-offset 0)
933     &rest function-args)
934     "Applies FUNCTION to children, overlapping REGION, in the order they
935     were added."
936     (declare (ignore x-offset y-offset))
937     (loop with children = (output-record-children record)
938     for child across children
939     when (region-intersects-region-p region child)
940     do (apply function child function-args)))
941 rouanet 1.11
942 afuchs 1.122
943     ;;; tree output recording
944    
945     (defclass tree-output-record-entry ()
946     ((record :initarg :record :reader tree-output-record-entry-record)
947     (cached-rectangle :initform nil :accessor tree-output-record-entry-cached-rectangle)
948     (inserted-nr :initarg :inserted-nr :accessor tree-output-record-entry-inserted-nr)))
949    
950     (defun make-tree-output-record-entry (record inserted-nr)
951     (make-instance 'tree-output-record-entry :record record :inserted-nr inserted-nr))
952    
953     (defun %record-to-spatial-tree-rectangle (r)
954     (rectangles:make-rectangle
955     :lows `(,(bounding-rectangle-min-x r)
956     ,(bounding-rectangle-min-y r))
957     :highs `(,(bounding-rectangle-max-x r)
958     ,(bounding-rectangle-max-y r))))
959    
960     (defun %output-record-entry-to-spatial-tree-rectangle (r)
961     (when (null (tree-output-record-entry-cached-rectangle r))
962     (let* ((record (tree-output-record-entry-record r)))
963     (setf (tree-output-record-entry-cached-rectangle r) (%record-to-spatial-tree-rectangle record))))
964     (tree-output-record-entry-cached-rectangle r))
965    
966     (defun %make-tree-output-record-tree ()
967     (spatial-trees:make-spatial-tree :r
968     :rectfun #'%output-record-entry-to-spatial-tree-rectangle))
969    
970     (defclass standard-tree-output-record (compound-output-record)
971     ((children :initform (%make-tree-output-record-tree)
972     :accessor %tree-record-children)
973     (children-hash :initform (make-hash-table :test #'eql) :reader %tree-record-children-cache)
974     (last-insertion-nr :initform 0 :accessor last-insertion-nr)))
975    
976     (defun %entry-in-children-cache (record entry)
977     (gethash entry (%tree-record-children-cache record)))
978    
979     (defun (setf %entry-in-children-cache) (new-val record entry)
980     (setf (gethash entry (%tree-record-children-cache record)) new-val))
981    
982 afuchs 1.123 (defun %remove-entry-from-children-cache (record entry)
983     (remhash entry (%tree-record-children-cache record)))
984    
985 afuchs 1.122 (defmethod output-record-children ((record standard-tree-output-record))
986     (map 'list
987     #'tree-output-record-entry-record
988     (spatial-trees:search (%record-to-spatial-tree-rectangle record)
989     (%tree-record-children record))))
990    
991     (defmethod add-output-record (child (record standard-tree-output-record))
992     (let ((entry (make-tree-output-record-entry child (incf (last-insertion-nr record)))))
993     (spatial-trees:insert entry (%tree-record-children record))
994     (setf (output-record-parent child) record)
995     (setf (%entry-in-children-cache record child) entry)))
996    
997     (defmethod delete-output-record (child (record standard-tree-output-record) &optional (errorp t))
998     (let ((entry (find child (spatial-trees:search (%entry-in-children-cache record child)
999     (%tree-record-children record))
1000     :key #'tree-output-record-entry-record)))
1001     (cond
1002     ((not (null entry))
1003     (spatial-trees:delete entry (%tree-record-children record))
1004 afuchs 1.123 (%remove-entry-from-children-cache record child)
1005 afuchs 1.122 (setf (output-record-parent child) nil))
1006     (errorp (error "~S is not a child of ~S" child record)))))
1007    
1008     (defmethod clear-output-record ((record standard-tree-output-record))
1009     (dolist (child (output-record-children record))
1010     (setf (output-record-parent child) nil)
1011 afuchs 1.123 (%remove-entry-from-children-cache record child))
1012 afuchs 1.122 (setf (%tree-record-children record) (%make-tree-output-record-tree)))
1013    
1014     (defun map-over-tree-output-records (function record rectangle sort-order function-args)
1015     (dolist (child (sort (spatial-trees:search rectangle
1016     (%tree-record-children record))
1017     (ecase sort-order
1018     (:most-recent-first #'>)
1019     (:most-recent-last #'<))
1020     :key #'tree-output-record-entry-inserted-nr))
1021     (apply function (tree-output-record-entry-record child) function-args)))
1022    
1023     (defmethod map-over-output-records-1 (function (record standard-tree-output-record) function-args)
1024     (map-over-tree-output-records function record (%record-to-spatial-tree-rectangle record) :most-recent-last
1025     function-args))
1026    
1027     (defmethod map-over-output-records-containing-position (function (record standard-tree-output-record) x y &optional x-offset y-offset &rest function-args)
1028     (declare (ignore x-offset y-offset))
1029     (map-over-tree-output-records function record (rectangles:make-rectangle :lows `(,x ,y) :highs `(,x ,y)) :most-recent-first
1030     function-args))
1031    
1032     (defmethod map-over-output-records-overlapping-region (function (record standard-tree-output-record) region &optional x-offset y-offset &rest function-args)
1033     (declare (ignore x-offset y-offset))
1034     (typecase region
1035     (everywhere-region (map-over-output-records-1 function record function-args))
1036     (nowhere-region nil)
1037     (otherwise (map-over-tree-output-records
1038     (lambda (child)
1039     (if (region-intersects-region-p (multiple-value-call 'make-rectangle* (bounding-rectangle* child))
1040     region)
1041     (apply function child function-args)))
1042     record (%record-to-spatial-tree-rectangle (bounding-rectangle region)) :most-recent-last
1043     nil))))
1044    
1045     (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)
1046     (when (eql record (output-record-parent child))
1047     (let ((entry (%entry-in-children-cache record child)))
1048     (spatial-trees:delete entry (%tree-record-children record))
1049     (setf (tree-output-record-entry-cached-rectangle entry) nil)
1050     (spatial-trees:insert entry (%tree-record-children record))))
1051     (call-next-method))
1052    
1053     ;;;
1054 mikemac 1.1
1055 moore 1.57 (defmethod match-output-records ((record t) &rest args)
1056     (apply #'match-output-records-1 record args))
1057    
1058     ;;; Factor out the graphics state portions of the output records so
1059     ;;; they can be manipulated seperately e.g., by incremental
1060     ;;; display. The individual slots of a graphics state are factored into mixin
1061     ;;; classes so that each output record can capture only the state that it needs.
1062     ;;; -- moore
1063    
1064     ;;; It would be appealing to define a setf method, e.g. (setf
1065     ;;; medium-graphics-state), for setting a medium's state from a graphics state
1066     ;;; object, but that would require us to define a medium-graphics-state reader
1067     ;;; that would cons a state object. I don't want to do that.
1068    
1069     (defclass graphics-state ()
1070     ()
1071     (:documentation "Stores those parts of the medium/stream graphics state
1072     that need to be restored when drawing an output record"))
1073    
1074     (defclass gs-ink-mixin (graphics-state)
1075     ((ink :initarg :ink :accessor graphics-state-ink)))
1076    
1077     (defmethod initialize-instance :after ((obj gs-ink-mixin)
1078     &key (stream nil)
1079     (medium (when stream
1080     (sheet-medium stream))))
1081     (when (and medium (not (slot-boundp obj 'ink)))
1082     (setf (slot-value obj 'ink) (medium-ink medium))))
1083    
1084 crhodes 1.127 (defmethod replay-output-record :around
1085     ((record gs-ink-mixin) stream &optional region x-offset y-offset)
1086 rstrandh 1.134 (declare (ignore region x-offset y-offset))
1087 crhodes 1.127 (with-drawing-options (stream :ink (graphics-state-ink record))
1088     (call-next-method)))
1089 moore 1.57
1090 moore 1.64 (defrecord-predicate gs-ink-mixin (ink)
1091 hefner1 1.84 (if-supplied (ink)
1092 moore 1.64 (design-equalp (slot-value record 'ink) ink)))
1093 moore 1.57
1094     (defclass gs-clip-mixin (graphics-state)
1095     ((clip :initarg :clipping-region :accessor graphics-state-clip
1096     :documentation "Clipping region in stream coordinates.")))
1097    
1098     (defmethod initialize-instance :after ((obj gs-clip-mixin)
1099     &key (stream nil)
1100     (medium (when stream
1101     (sheet-medium stream))))
1102     (when medium
1103     (with-slots (clip)
1104     obj
1105     (let ((clip-region (if (slot-boundp obj 'clip)
1106     (region-intersection (medium-clipping-region
1107     medium)
1108     clip)
1109     (medium-clipping-region medium))))
1110     (setq clip (transform-region (medium-transformation medium)
1111     clip-region))))))
1112    
1113 crhodes 1.127 (defmethod replay-output-record :around
1114     ((record gs-clip-mixin) stream &optional region x-offset y-offset)
1115 rstrandh 1.134 (declare (ignore region x-offset y-offset))
1116 crhodes 1.127 (with-drawing-options (stream :clipping-region (graphics-state-clip record))
1117     (call-next-method)))
1118 moore 1.57
1119 moore 1.64 (defrecord-predicate gs-clip-mixin ((:clipping-region clip))
1120 hefner1 1.84 (if-supplied (clip)
1121 moore 1.64 (region-equal (slot-value record 'clip) clip)))
1122    
1123 adejneka 1.46 ;;; 16.3.2. Graphics Displayed Output Records
1124 moore 1.57 (defclass standard-displayed-output-record (gs-clip-mixin gs-ink-mixin
1125     basic-output-record
1126 adejneka 1.46 displayed-output-record)
1127 moore 1.112 ((ink :reader displayed-output-record-ink)
1128     (stream :initarg :stream))
1129     (:documentation "Implementation class for DISPLAYED-OUTPUT-RECORD.")
1130     (:default-initargs :stream nil))
1131 mikemac 1.1
1132 moore 1.57 (defclass gs-line-style-mixin (graphics-state)
1133     ((line-style :initarg :line-style :accessor graphics-state-line-style)))
1134    
1135     (defmethod initialize-instance :after ((obj gs-line-style-mixin)
1136     &key (stream nil)
1137     (medium (when stream
1138     (sheet-medium stream))))
1139     (when medium
1140     (unless (slot-boundp obj 'line-style)
1141     (setf (slot-value obj 'line-style) (medium-line-style medium)))))
1142    
1143 crhodes 1.127 (defmethod replay-output-record :around
1144     ((record gs-line-style-mixin) stream &optional region x-offset y-offset)
1145 rstrandh 1.134 (declare (ignore region x-offset y-offset))
1146 crhodes 1.127 (with-drawing-options (stream :line-style (graphics-state-line-style record))
1147     (call-next-method)))
1148 moore 1.57
1149 moore 1.64 (defrecord-predicate gs-line-style-mixin (line-style)
1150 hefner1 1.84 (if-supplied (line-style)
1151 moore 1.64 (line-style-equalp (slot-value record 'line-style) line-style)))
1152 moore 1.57
1153     (defgeneric graphics-state-line-style-border (record medium)
1154     (:method ((record gs-line-style-mixin) medium)
1155     (/ (line-style-effective-thickness (graphics-state-line-style record)
1156     medium)
1157     2)))
1158    
1159     (defclass gs-text-style-mixin (graphics-state)
1160     ((text-style :initarg :text-style :accessor graphics-state-text-style)))
1161    
1162     (defmethod initialize-instance :after ((obj gs-text-style-mixin)
1163     &key (stream nil)
1164     (medium (when stream
1165     (sheet-medium stream))))
1166     (when medium
1167     (unless (slot-boundp obj 'text-style)
1168     (setf (slot-value obj 'text-style) (medium-text-style medium)))))
1169    
1170 crhodes 1.127 (defmethod replay-output-record :around
1171     ((record gs-text-style-mixin) stream &optional region x-offset y-offset)
1172 rstrandh 1.134 (declare (ignore region x-offset y-offset))
1173 crhodes 1.127 (with-drawing-options (stream :text-style (graphics-state-text-style record))
1174     (call-next-method)))
1175 moore 1.57
1176 moore 1.64 (defrecord-predicate gs-text-style-mixin (text-style)
1177 hefner1 1.84 (if-supplied (text-style)
1178 moore 1.64 (text-style-equalp (slot-value record 'text-style) text-style)))
1179 moore 1.57
1180 adejneka 1.46 (defclass standard-graphics-displayed-output-record
1181 moore 1.57 (standard-displayed-output-record
1182     graphics-displayed-output-record)
1183     ())
1184    
1185     (defmethod match-output-records-1 and
1186     ((record standard-displayed-output-record)
1187     &key (x1 nil x1-p) (y1 nil y1-p)
1188     (x2 nil x2-p) (y2 nil y2-p)
1189     (bounding-rectangle nil bounding-rectangle-p))
1190     (if bounding-rectangle-p
1191     (region-equal record bounding-rectangle)
1192     (multiple-value-bind (my-x1 my-y1 my-x2 my-y2)
1193     (bounding-rectangle* record)
1194 hefner1 1.84 (macrolet ((coordinate=-or-lose (key mine)
1195     `(if (typep ,key 'coordinate)
1196     (coordinate= ,mine ,key)
1197     (error 'type-error
1198     :datum ,key
1199     :expected-type 'coordinate))))
1200     (and (or (null x1-p)
1201     (coordinate=-or-lose x1 my-x1))
1202     (or (null y1-p)
1203     (coordinate=-or-lose y1 my-y1))
1204     (or (null x2-p)
1205     (coordinate=-or-lose x2 my-x2))
1206     (or (null y2-p)
1207     (coordinate=-or-lose y2 my-y2)))))))
1208 moore 1.57
1209 moore 1.64 (defmethod output-record-equal and ((record standard-displayed-output-record)
1210     (record2 standard-displayed-output-record))
1211     (region-equal record record2))
1212    
1213 moore 1.57 (defclass coord-seq-mixin ()
1214     ((coord-seq :accessor coord-seq :initarg :coord-seq))
1215     (:documentation "Mixin class that implements methods for records that contain
1216     sequences of coordinates."))
1217    
1218     (defun coord-seq-bounds (coord-seq border)
1219 gilbert 1.73 (setf border (ceiling border))
1220 moore 1.57 (let* ((min-x (elt coord-seq 0))
1221     (min-y (elt coord-seq 1))
1222     (max-x min-x)
1223     (max-y min-y))
1224     (do-sequence ((x y) coord-seq)
1225     (minf min-x x)
1226     (minf min-y y)
1227     (maxf max-x x)
1228     (maxf max-y y))
1229 gilbert 1.73 (values (floor (- min-x border))
1230     (floor (- min-y border))
1231     (ceiling (+ max-x border))
1232     (ceiling (+ max-y border)))))
1233 moore 1.57
1234 tmoore 1.117 ;;; record must be a standard-rectangle
1235 mikemac 1.1
1236 moore 1.57 (defmethod* (setf output-record-position) :around
1237     (nx ny (record coord-seq-mixin))
1238 tmoore 1.117 (with-standard-rectangle* (:x1 x1 :y1 y1)
1239 moore 1.57 record
1240     (let ((dx (- nx x1))
1241     (dy (- ny y1))
1242     (coords (slot-value record 'coord-seq)))
1243     (multiple-value-prog1
1244     (call-next-method)
1245     (loop for i from 0 below (length coords) by 2
1246     do (progn
1247     (incf (aref coords i) dx)
1248 gilbert 1.59 (incf (aref coords (1+ i)) dy)))))))
1249 moore 1.57
1250     (defmethod match-output-records-1 and ((record coord-seq-mixin)
1251     &key (coord-seq nil coord-seq-p))
1252     (or (null coord-seq-p)
1253     (let* ((my-coord-seq (slot-value record 'coord-seq))
1254     (len (length my-coord-seq)))
1255     (and (eql len (length coord-seq))
1256     (loop for elt1 across my-coord-seq
1257     for elt2 across coord-seq
1258     always (coordinate= elt1 elt2))))))
1259    
1260 hefner1 1.104 (defmacro generate-medium-recording-body (class-name method-name args)
1261     (let ((arg-list (loop for arg in args
1262     nconc `(,(intern (symbol-name arg) :keyword) ,arg))))
1263     `(with-sheet-medium (medium stream)
1264     (when (stream-recording-p stream)
1265     (let ((record
1266     ;; Hack: the coord-seq-mixin makes the assumption that, well
1267     ;; coord-seq is a coord-vector. So we morph a possible
1268     ;; coord-seq argument into a vector.
1269     (let (,@(when (member 'coord-seq args)
1270     `((coord-seq
1271     (if (vectorp coord-seq)
1272     coord-seq
1273     (coerce coord-seq 'vector))))))
1274     (make-instance ',class-name
1275     :stream stream
1276     ,@arg-list))))
1277     (stream-add-output-record stream record)))
1278     (when (stream-drawing-p stream)
1279     (,method-name medium ,@args)))))
1280    
1281     ;; DEF-GRECORDING: This is the central interface through which recording
1282     ;; is implemented for drawing functions. The body provided is used to
1283     ;; compute the bounding rectangle of the rendered output. DEF-GRECORDING
1284     ;; will define a class for the output record, with slots corresponding to the
1285     ;; drawing function arguments. It also defines an INITIALIZE-INSTANCE method
1286     ;; computing the bounding rectangle of the record. It defines a method for
1287     ;; the medium drawing function specialized on output-recording-stream, which
1288     ;; is responsible for creating the output record and adding it to the stream
1289     ;; history. It also defines a REPLAY-OUTPUT-RECORD method, which calls the
1290     ;; medium drawing function based on the recorded slots.
1291    
1292     (defmacro def-grecording (name ((&rest mixins) &rest args)
1293     (&key (class t)
1294     (medium-fn t)
1295     (replay-fn t)) &body body)
1296 gilbert 1.56 (let ((method-name (symbol-concat '#:medium- name '*))
1297 mikemac 1.63 (class-name (symbol-concat name '#:-output-record))
1298 adejneka 1.41 (medium (gensym "MEDIUM"))
1299 adejneka 1.46 (class-vars `((stream :initarg :stream)
1300     ,@(loop for arg in args
1301     collect `(,arg
1302     :initarg ,(intern (symbol-name arg)
1303 hefner1 1.104 :keyword))))))
1304 cvs 1.10 `(progn
1305 hefner1 1.104 ,@(when class
1306     `((defclass ,class-name (,@mixins standard-graphics-displayed-output-record)
1307     ,class-vars)
1308 tmoore 1.117 (defmethod initialize-instance :after ((graphic ,class-name)
1309     &key)
1310     (with-slots (stream ink clipping-region
1311 hefner1 1.104 line-style text-style ,@args)
1312     graphic
1313     (let* ((medium (sheet-medium stream)))
1314 tmoore 1.117 (setf (rectangle-edges* graphic)
1315     (progn ,@body)))))))
1316 hefner1 1.104 ,(when medium-fn
1317     `(defmethod ,method-name :around ((stream output-recording-stream) ,@args)
1318     ;; XXX STANDARD-OUTPUT-RECORDING-STREAM ^?
1319     (generate-medium-recording-body ,class-name ,method-name ,args)))
1320     ,(when replay-fn
1321     `(defmethod replay-output-record ((record ,class-name) stream
1322     &optional (region +everywhere+)
1323     (x-offset 0) (y-offset 0))
1324     (declare (ignore x-offset y-offset region))
1325     (with-slots (,@args) record
1326     (let ((,medium (sheet-medium stream))
1327     ;; is sheet a sheet-with-medium-mixin? --GB
1328     )
1329     ;; Graphics state is set up in :around method.
1330     (,method-name ,medium ,@args))))))))
1331 mikemac 1.1
1332 hefner1 1.104 (def-grecording draw-point ((gs-line-style-mixin) point-x point-y) ()
1333 moore 1.57 (let ((border (graphics-state-line-style-border graphic medium)))
1334     (with-transformed-position ((medium-transformation medium) point-x point-y)
1335     (setf (slot-value graphic 'point-x) point-x
1336     (slot-value graphic 'point-y) point-y)
1337     (values (- point-x border)
1338     (- point-y border)
1339     (+ point-x border)
1340     (+ point-y border)))))
1341    
1342     (defmethod* (setf output-record-position) :around
1343     (nx ny (record draw-point-output-record))
1344 tmoore 1.117 (with-standard-rectangle* (:x1 x1 :y1 y1)
1345     record
1346     (with-slots (point-x point-y)
1347     record
1348     (let ((dx (- nx x1))
1349     (dy (- ny y1)))
1350     (multiple-value-prog1
1351     (call-next-method)
1352     (incf point-x dx)
1353     (incf point-y dy))))))
1354 moore 1.57
1355 moore 1.64 (defrecord-predicate draw-point-output-record (point-x point-y)
1356 hefner1 1.84 (and (if-supplied (point-x coordinate)
1357 moore 1.64 (coordinate= (slot-value record 'point-x) point-x))
1358 hefner1 1.84 (if-supplied (point-y coordinate)
1359 moore 1.64 (coordinate= (slot-value record 'point-y) point-y))))
1360 moore 1.57
1361 hefner1 1.104 (def-grecording draw-points ((coord-seq-mixin gs-line-style-mixin) coord-seq) ()
1362 hefner1 1.92 (let ((transformed-coord-seq (transform-positions (medium-transformation medium) coord-seq))
1363 moore 1.91 (border (graphics-state-line-style-border graphic medium)))
1364     (setf (slot-value graphic 'coord-seq) transformed-coord-seq)
1365     (coord-seq-bounds transformed-coord-seq border)))
1366 moore 1.57
1367     (def-grecording draw-line ((gs-line-style-mixin)
1368 hefner1 1.104 point-x1 point-y1 point-x2 point-y2) ()
1369 moore 1.57 (let ((transform (medium-transformation medium))
1370     (border (graphics-state-line-style-border graphic medium)))
1371     (with-transformed-position (transform point-x1 point-y1)
1372     (with-transformed-position (transform point-x2 point-y2)
1373     (setf (slot-value graphic 'point-x1) point-x1
1374     (slot-value graphic 'point-y1) point-y1
1375     (slot-value graphic 'point-x2) point-x2
1376     (slot-value graphic 'point-y2) point-y2)
1377     (values (- (min point-x1 point-x2) border)
1378     (- (min point-y1 point-y2) border)
1379     (+ (max point-x1 point-x2) border)
1380     (+ (max point-y1 point-y2) border))))))
1381    
1382     (defmethod* (setf output-record-position) :around
1383     (nx ny (record draw-line-output-record))
1384 tmoore 1.117 (with-standard-rectangle* (:x1 x1 :y1 y1)
1385 moore 1.57 record
1386 tmoore 1.117 (with-slots (point-x1 point-y1 point-x2 point-y2)
1387     record
1388     (let ((dx (- nx x1))
1389     (dy (- ny y1)))
1390     (multiple-value-prog1
1391     (call-next-method)
1392     (incf point-x1 dx)
1393     (incf point-y1 dy)
1394     (incf point-x2 dx)
1395     (incf point-y2 dy))))))
1396 moore 1.57
1397 moore 1.64 (defrecord-predicate draw-line-output-record (point-x1 point-y1
1398     point-x2 point-y2)
1399 hefner1 1.84 (and (if-supplied (point-x1 coordinate)
1400 moore 1.64 (coordinate= (slot-value record 'point-x1) point-x1))
1401 hefner1 1.84 (if-supplied (point-y1 coordinate)
1402 moore 1.64 (coordinate= (slot-value record 'point-y1) point-y1))
1403 hefner1 1.84 (if-supplied (point-x2 coordinate)
1404 moore 1.64 (coordinate= (slot-value record 'point-x2) point-x2))
1405 hefner1 1.84 (if-supplied (point-y2 coordinate)
1406 moore 1.64 (coordinate= (slot-value record 'point-y2) point-y2))))
1407 moore 1.57
1408 hefner1 1.104 (def-grecording draw-lines ((coord-seq-mixin gs-line-style-mixin) coord-seq) ()
1409 hefner1 1.92 (let ((transformed-coord-seq (transform-positions (medium-transformation medium) coord-seq))
1410 moore 1.91 (border (graphics-state-line-style-border graphic medium)))
1411     (setf coord-seq transformed-coord-seq)
1412     (coord-seq-bounds transformed-coord-seq border)))
1413 moore 1.57
1414 moore 1.64 ;;; (setf output-record-position) and predicates for draw-lines-output-record
1415     ;;; are taken care of by methods on superclasses.
1416    
1417 moore 1.57 ;;; Helper function
1418     (defun normalize-coords (dx dy &optional unit)
1419     (let ((norm (sqrt (+ (* dx dx) (* dy dy)))))
1420 moore 1.106 (cond ((= norm 0.0d0)
1421     (values 0.0d0 0.0d0))
1422     (unit
1423     (let ((scale (/ unit norm)))
1424     (values (* dx scale) (* dy scale))))
1425     (t (values (/ dx norm) (/ dy norm))))))
1426 mikemac 1.1
1427 adejneka 1.52 (defun polygon-record-bounding-rectangle
1428 moore 1.57 (coord-seq closed filled line-style border miter-limit)
1429 moore 1.54 (cond (filled
1430 moore 1.57 (coord-seq-bounds coord-seq 0))
1431 moore 1.54 ((eq (line-style-joint-shape line-style) :round)
1432 moore 1.57 (coord-seq-bounds coord-seq border))
1433     (t (let* ((x1 (svref coord-seq 0))
1434     (y1 (svref coord-seq 1))
1435     (min-x x1)
1436     (min-y y1)
1437     (max-x x1)
1438     (max-y y1)
1439     (len (length coord-seq)))
1440     (unless closed
1441     (setq min-x (- x1 border) min-y (- y1 border)
1442     max-x (+ x1 border) max-y (+ y1 border)))
1443     ;; Setup for iterating over the coordinate vector. If the polygon
1444     ;; is closed deal with the extra segment.
1445     (multiple-value-bind (initial-xp initial-yp
1446     final-xn final-yn
1447     initial-index final-index)
1448     (if closed
1449     (values (svref coord-seq (- len 2))
1450     (svref coord-seq (- len 1))
1451     x1 y1
1452     0 (- len 2))
1453     (values x1 y1
1454     (svref coord-seq (- len 2))
1455     (svref coord-seq (- len 1))
1456     2 (- len 4)))
1457     (ecase (line-style-joint-shape line-style)
1458     (:miter
1459     ;;FIXME: Remove successive positively proportional segments
1460     (loop with sin-limit = (sin (* 0.5 miter-limit))
1461     and xn and yn
1462     for i from initial-index to final-index by 2
1463     for xp = initial-xp then x
1464     for yp = initial-yp then y
1465     for x = (svref coord-seq i)
1466     for y = (svref coord-seq (1+ i))
1467     do (setf (values xn yn)
1468     (if (eql i final-index)
1469     (values final-xn final-yn)
1470     (values (svref coord-seq (+ i 2))
1471     (svref coord-seq (+ i
1472     3)))))
1473     (multiple-value-bind (ex1 ey1)
1474     (normalize-coords (- x xp) (- y yp))
1475     (multiple-value-bind (ex2 ey2)
1476     (normalize-coords (- x xn) (- y yn))
1477     (let* ((cos-a (+ (* ex1 ex2) (* ey1 ey2)))
1478     (sin-a/2 (sqrt (* 0.5 (- 1.0 cos-a)))))
1479     (if (< sin-a/2 sin-limit)
1480     (let ((nx (* border
1481     (max (abs ey1) (abs ey2))))
1482     (ny (* border
1483     (max (abs ex1) (abs ex2)))))
1484     (minf min-x (- x nx))
1485     (minf min-y (- y ny))
1486     (maxf max-x (+ x nx))
1487     (maxf max-y (+ y ny)))
1488     (let ((length (/ border sin-a/2)))
1489     (multiple-value-bind (dx dy)
1490     (normalize-coords (+ ex1 ex2)
1491     (+ ey1 ey2)
1492     length)
1493     (minf min-x (+ x dx))
1494     (minf min-y (+ y dy))
1495     (maxf max-x (+ x dx))
1496     (maxf max-y (+ y dy))))))))))
1497     ((:bevel :none)
1498     (loop with xn and yn
1499     for i from initial-index to final-index by 2
1500     for xp = initial-xp then x
1501     for yp = initial-yp then y
1502     for x = (svref coord-seq i)
1503     for y = (svref coord-seq (1+ i))
1504     do (setf (values xn yn)
1505     (if (eql i final-index)
1506     (values final-xn final-yn)
1507     (values (svref coord-seq (+ i 2))
1508     (svref coord-seq (+ i
1509     3)))))
1510     (multiple-value-bind (ex1 ey1)
1511     (normalize-coords (- x xp) (- y yp))
1512     (multiple-value-bind (ex2 ey2)
1513     (normalize-coords (- x xn) (- y yn))
1514     (let ((nx (* border (max (abs ey1) (abs ey2))))
1515     (ny (* border (max (abs ex1) (abs ex2)))))
1516     (minf min-x (- x nx))
1517     (minf min-y (- y ny))
1518     (maxf max-x (+ x nx))
1519     (maxf max-y (+ y ny))))))))
1520     (unless closed
1521     (multiple-value-bind (x y)
1522     (values (svref coord-seq final-index)
1523     (svref coord-seq (1+ final-index)))
1524     (minf min-x (- x border))
1525     (minf min-y (- y border))
1526     (maxf max-x (+ x border))
1527     (maxf max-y (+ y border)))))
1528     (values min-x min-y max-x max-y)))))
1529    
1530     (def-grecording draw-polygon ((coord-seq-mixin gs-line-style-mixin)
1531 hefner1 1.104 coord-seq closed filled) ()
1532 hefner1 1.92 (let ((transformed-coord-seq (transform-positions (medium-transformation medium) coord-seq))
1533 moore 1.91 (border (graphics-state-line-style-border graphic medium)))
1534     (setf coord-seq transformed-coord-seq)
1535     (polygon-record-bounding-rectangle transformed-coord-seq
1536     closed filled line-style border
1537     (medium-miter-limit medium))))
1538 moore 1.57
1539 moore 1.64 (defrecord-predicate draw-polygon-output-record (closed filled)
1540 hefner1 1.84 (and (if-supplied (closed)
1541 moore 1.64 (eql (slot-value record 'closed) closed))
1542 hefner1 1.84 (if-supplied (filled)
1543 moore 1.64 (eql (slot-value record 'filled) filled))))
1544 moore 1.57
1545     (def-grecording draw-rectangle ((gs-line-style-mixin)
1546 hefner1 1.104 left top right bottom filled) (:medium-fn nil)
1547     (let* ((transform (medium-transformation medium))
1548     (border (graphics-state-line-style-border graphic medium))
1549     (pre-coords (expand-rectangle-coords left top right bottom))
1550     (coords (transform-positions transform pre-coords)))
1551 moore 1.101 (setf (values left top) (transform-position transform left top))
1552     (setf (values right bottom) (transform-position transform right bottom))
1553 hefner1 1.104 (polygon-record-bounding-rectangle coords t filled line-style border
1554     (medium-miter-limit medium))))
1555    
1556     (defmethod medium-draw-rectangle* :around ((stream output-recording-stream) left top right bottom filled)
1557     (let ((tr (medium-transformation stream)))
1558     (if (rectilinear-transformation-p tr)
1559 moore 1.106 (generate-medium-recording-body draw-rectangle-output-record
1560     medium-draw-rectangle*
1561     (left top right bottom filled))
1562     (medium-draw-polygon* stream
1563     (expand-rectangle-coords left top right bottom)
1564     t
1565     filled))))
1566 moore 1.57
1567     (defmethod* (setf output-record-position) :around
1568     (nx ny (record draw-rectangle-output-record))
1569 tmoore 1.117 (with-standard-rectangle* (:x1 x1 :y1 y1)
1570 moore 1.57 record
1571 tmoore 1.117 (with-slots (left top right bottom)
1572     record
1573     (let ((dx (- nx x1))
1574     (dy (- ny y1)))
1575     (multiple-value-prog1
1576     (call-next-method)
1577     (incf left dx)
1578     (incf top dy)
1579     (incf right dx)
1580     (incf bottom dy))))))
1581 moore 1.57
1582 moore 1.64 (defrecord-predicate draw-rectangle-output-record (left top right bottom filled)
1583 hefner1 1.84 (and (if-supplied (left coordinate)
1584 moore 1.64 (coordinate= (slot-value record 'left) left))
1585 hefner1 1.84 (if-supplied (top coordinate)
1586 moore 1.64 (coordinate= (slot-value record 'top) top))
1587 hefner1 1.84 (if-supplied (right coordinate)
1588 moore 1.64 (coordinate= (slot-value record 'right) right))
1589 hefner1 1.84 (if-supplied (bottom coordinate)
1590 moore 1.64 (coordinate= (slot-value record 'bottom) bottom))
1591 hefner1 1.84 (if-supplied (filled)
1592 moore 1.64 (eql (slot-value record 'filled) filled))))
1593 mikemac 1.1
1594 moore 1.57 (def-grecording draw-ellipse ((gs-line-style-mixin)
1595     center-x center-y
1596 mikemac 1.1 radius-1-dx radius-1-dy radius-2-dx radius-2-dy
1597 hefner1 1.104 start-angle end-angle filled) ()
1598 moore 1.101 (let ((transform (medium-transformation medium)))
1599     (setf (values center-x center-y)
1600     (transform-position transform center-x center-y))
1601     (setf (values radius-1-dx radius-1-dy)
1602     (transform-distance transform radius-1-dx radius-1-dy))
1603     (setf (values radius-2-dx radius-2-dy)
1604     (transform-distance transform radius-2-dx radius-2-dy))
1605 hefner1 1.103 ;; I think this should be untransform-angle below, as the ellipse angles
1606     ;; go counter-clockwise in screen coordinates, whereas our transformations
1607 hefner1 1.115 ;; rotate clockwise in the default coorinate system.. this is quite possibly
1608     ;; wrong depending on how one reads the spec, but just reversing it here
1609     ;; will break other things. -Hefner
1610 hefner1 1.103 (setf start-angle (untransform-angle transform start-angle))
1611     (setf end-angle (untransform-angle transform end-angle))
1612 crhodes 1.118 (when (reflection-transformation-p transform)
1613     (rotatef start-angle end-angle))
1614 moore 1.101 (multiple-value-bind (min-x min-y max-x max-y)
1615     (bounding-rectangle* (make-ellipse* center-x center-y
1616     radius-1-dx radius-1-dy
1617     radius-2-dx radius-2-dy
1618     :start-angle start-angle
1619     :end-angle end-angle))
1620     (if filled
1621     (values min-x min-y max-x max-y)
1622     (let ((border (graphics-state-line-style-border graphic medium)))
1623     (values (- min-x border)
1624     (- min-y border)
1625     (+ max-x border)
1626     (+ max-y border)))))))
1627 moore 1.57
1628     (defmethod* (setf output-record-position) :around
1629     (nx ny (record draw-ellipse-output-record))
1630 tmoore 1.117 (with-standard-rectangle* (:x1 x1 :y1 y1)
1631 moore 1.57 record
1632 tmoore 1.117 (with-slots (center-x center-y)
1633     record
1634     (let ((dx (- nx x1))
1635     (dy (- ny y1)))
1636     (multiple-value-prog1
1637     (call-next-method)
1638     (incf center-x dx)
1639     (incf center-y dy))))))
1640 moore 1.57
1641 moore 1.64 (defrecord-predicate draw-ellipse-output-record (center-x center-y)
1642 hefner1 1.84 (and (if-supplied (center-x coordinate)
1643     (coordinate= (slot-value record 'center-x) center-x))
1644     (if-supplied (center-y coordinate)
1645     (coordinate= (slot-value record 'center-y) center-y))))
1646 rouanet 1.11
1647 gilbert 1.88 ;;;; Patterns
1648    
1649 moore 1.101 ;;; The Spec says that "transformation only affects the position at
1650     ;;; which the pattern is drawn, not the pattern itself"
1651 hefner1 1.104 (def-grecording draw-pattern (() pattern x y) ()
1652 gilbert 1.88 (let ((width (pattern-width pattern))
1653 moore 1.101 (height (pattern-height pattern))
1654     (transform (medium-transformation medium)))
1655     (setf (values x y) (transform-position transform x y))
1656 gilbert 1.88 (values x y (+ x width) (+ y height))))
1657    
1658 tmoore 1.117 (defmethod* (setf output-record-position) :around
1659     (nx ny (record draw-pattern-output-record))
1660     (with-standard-rectangle* (:x1 x1 :y1 y1)
1661     record
1662     (with-slots (x y)
1663 gilbert 1.88 record
1664     (let ((dx (- nx x1))
1665     (dy (- ny y1)))
1666     (multiple-value-prog1
1667     (call-next-method)
1668     (incf x dx)
1669 tmoore 1.117 (incf y dy))))))
1670 gilbert 1.88
1671     (defrecord-predicate draw-pattern-output-record (x y pattern)
1672     ;; ### I am not so sure about the correct usage of DEFRECORD-PREDICATE
1673     ;; --GB 2003-08-15
1674     (and (if-supplied (x coordinate)
1675     (coordinate= (slot-value record 'x) x))
1676     (if-supplied (y coordinate)
1677     (coordinate= (slot-value record 'y) y))
1678     (if-supplied (pattern pattern)
1679     (eq (slot-value record 'pattern) pattern))))
1680    
1681     ;;;; Text
1682    
1683 moore 1.57 (def-grecording draw-text ((gs-text-style-mixin) string point-x point-y start end
1684 hefner1 1.104 align-x align-y toward-x toward-y transform-glyphs) ()
1685 adejneka 1.44 ;; FIXME!!! Text direction.
1686 crhodes 1.119 ;; FIXME: Multiple lines.
1687 moore 1.57 (let* ((text-style (graphics-state-text-style graphic))
1688 moore 1.67 (width (if (characterp string)
1689     (stream-character-width stream string :text-style text-style)
1690     (stream-string-width stream string
1691     :start start :end end
1692     :text-style text-style)) )
1693 strandh 1.26 (ascent (text-style-ascent text-style (sheet-medium stream)))
1694     (descent (text-style-descent text-style (sheet-medium stream)))
1695 crhodes 1.119 (transform (medium-transformation medium)))
1696 moore 1.101 (setf (values point-x point-y)
1697     (transform-position transform point-x point-y))
1698 crhodes 1.119 (multiple-value-bind (left top right bottom)
1699     (text-bounding-rectangle* medium string
1700     :start start :end end :text-style text-style)
1701     (ecase align-x
1702     (:left (incf left point-x) (incf right point-x))
1703     (:right (incf left (- point-x width)) (incf right (- point-x width)))
1704     (:center (incf left (- point-x (round width 2)))
1705     (incf right (- point-x (round width 2)))))
1706     (ecase align-y
1707     (:baseline (incf top point-y) (incf bottom point-y))
1708     (:top (incf top (+ point-y ascent))
1709     (incf bottom (+ point-y ascent)))
1710     (:bottom (incf top (- point-y descent))
1711     (incf bottom (- point-y descent)))
1712     (:center (incf top (+ point-y (ceiling (- ascent descent) 2)))
1713     (incf bottom (+ point-y (ceiling (- ascent descent) 2)))))
1714     (values left top right bottom))))
1715 mikemac 1.1
1716 moore 1.57 (defmethod* (setf output-record-position) :around
1717     (nx ny (record draw-text-output-record))
1718 tmoore 1.117 (with-standard-rectangle* (:x1 x1 :y1 y1)
1719 moore 1.57 record
1720 tmoore 1.117 (with-slots (point-x point-y toward-x toward-y)
1721     record
1722     (let ((dx (- nx x1))
1723     (dy (- ny y1)))
1724     (multiple-value-prog1
1725     (call-next-method)
1726     (incf point-x dx)
1727     (incf point-y dy)
1728     (incf toward-x dx)
1729     (incf toward-y dy))))))
1730 moore 1.57
1731 moore 1.64 (defrecord-predicate draw-text-output-record
1732     (string start end point-x point-y align-x align-y toward-x toward-y
1733     transform-glyphs)
1734 hefner1 1.84 (and (if-supplied (string)
1735 moore 1.64 (string= (slot-value record 'string) string))
1736 hefner1 1.84 (if-supplied (start)
1737 moore 1.64 (eql (slot-value record 'start) start))
1738 hefner1 1.84 (if-supplied (end)
1739 moore 1.64 (eql (slot-value record 'end) end))
1740 hefner1 1.84 (if-supplied (point-x coordinate)
1741 moore 1.64 (coordinate= (slot-value record 'point-x) point-x))
1742 hefner1 1.84 (if-supplied (point-y coordinate)
1743 moore 1.64 (coordinate= (slot-value record 'point-y) point-y))
1744 hefner1 1.84 (if-supplied (align-x)
1745 moore 1.64 (eq (slot-value record 'align-x) align-x))
1746 hefner1 1.84 (if-supplied (align-y)
1747 moore 1.64 (eq (slot-value record 'align-y) align-y))
1748 hefner1 1.84 (if-supplied (toward-x coordinate)
1749 moore 1.64 (coordinate= (slot-value record 'toward-x) toward-x))
1750 hefner1 1.84 (if-supplied (toward-y coordinate)
1751 moore 1.64 (coordinate= (slot-value record 'toward-y) toward-y))
1752 hefner1 1.84 (if-supplied (transform-glyphs)
1753 moore 1.64 (eq (slot-value record 'transform-glyphs) transform-glyphs))))
1754 moore 1.57
1755 adejneka 1.46 ;;; 16.3.3. Text Displayed Output Record
1756 adejneka 1.47
1757 moore 1.57 (defclass styled-string (gs-text-style-mixin gs-clip-mixin gs-ink-mixin)
1758 adejneka 1.47 ((start-x :initarg :start-x)
1759     (string :initarg :string :reader styled-string-string)))
1760 moore 1.34
1761 moore 1.64 (defmethod output-record-equal and ((record styled-string)
1762     (record2 styled-string))
1763     (and (coordinate= (slot-value record 'start-x)
1764     (slot-value record2 'start-x))
1765     (string= (slot-value record 'string)
1766     (slot-value record2 'string))))
1767    
1768 adejneka 1.46 (defclass standard-text-displayed-output-record
1769     (text-displayed-output-record standard-displayed-output-record)
1770 adejneka 1.47 ((initial-x1 :initarg :start-x)
1771     (initial-y1 :initarg :start-y)
1772     (strings :initform nil)
1773 mikemac 1.1 (baseline :initform 0)
1774 adejneka 1.22 (width :initform 0)
1775 mikemac 1.1 (max-height :initform 0)
1776 crhodes 1.119 ;; FIXME (or rework this comment): CLIM does not separate the
1777     ;; notions of the text width and the bounding box; however, we need
1778     ;; to, because some fonts will render outside the logical
1779     ;; coordinates defined by the start position and the width. LEFT
1780     ;; and RIGHT here (and below) deal with this in a manner completely
1781     ;; hidden from the user. (should we export
1782     ;; TEXT-BOUNDING-RECTANGLE*?)
1783     (left :initarg :start-x)
1784     (right :initarg :start-x)
1785 cvs 1.6 (start-x :initarg :start-x)
1786     (start-y :initarg :start-y)
1787 adejneka 1.47 (end-x :initarg :start-x)
1788     (end-y :initarg :start-y)
1789 cvs 1.8 (wrapped :initform nil
1790 moore 1.57 :accessor text-record-wrapped)
1791     (medium :initarg :medium :initform nil)))
1792    
1793     (defmethod initialize-instance :after
1794     ((obj standard-text-displayed-output-record) &key stream)
1795     (when stream
1796     (setf (slot-value obj 'medium) (sheet-medium stream))))
1797 mikemac 1.1
1798 moore 1.64 ;;; Forget match-output-records-1 for standard-text-displayed-output-record; it
1799     ;;; doesn't make much sense because these records have state that is not
1800     ;;; initialized via initargs.
1801    
1802     (defmethod output-record-equal and
1803     ((record standard-text-displayed-output-record)
1804     (record2 standard-text-displayed-output-record))
1805     (with-slots
1806 crhodes 1.119 (initial-x1 initial-y1 start-x start-y left right end-x end-y wrapped strings)
1807 moore 1.64 record2
1808     (and (coordinate= (slot-value record 'initial-x1) initial-x1)
1809     (coordinate= (slot-value record 'initial-y1) initial-y1)
1810     (coordinate= (slot-value record 'start-x) start-x)
1811     (coordinate= (slot-value record 'start-y) start-y)
1812 crhodes 1.119 (coordinate= (slot-value record 'left) left)
1813     (coordinate= (slot-value record 'right) right)
1814 moore 1.64 (coordinate= (slot-value record 'end-x) end-x)
1815     (coordinate= (slot-value record 'end-y) end-y)
1816     (eq (slot-value record 'wrapped) wrapped)
1817     (coordinate= (slot-value record 'baseline)
1818     (slot-value record2 'baseline))
1819     (eql (length (slot-value record 'strings)) (length strings));XXX
1820     (loop for s1 in (slot-value record 'strings)
1821     for s2 in strings
1822 mikemac 1.65 always (output-record-equal s1 s2)))))
1823 moore 1.64
1824 adejneka 1.46 (defmethod print-object ((self standard-text-displayed-output-record) stream)
1825 cvs 1.8 (print-unreadable-object (self stream :type t :identity t)
1826 adejneka 1.47 (with-slots (start-x start-y strings) self
1827     (format stream "~D,~D ~S"
1828     start-x start-y
1829     (mapcar #'styled-string-string strings)))))
1830 mikemac 1.1
1831 moore 1.112 (defmethod* (setf output-record-position) :around
1832 adejneka 1.46 (nx ny (record standard-text-displayed-output-record))
1833 tmoore 1.117 (with-standard-rectangle* (:x1 x1 :y1 y1)
1834 moore 1.112 record
1835 tmoore 1.117 (with-slots (start-x start-y end-x end-y strings baseline)
1836     record
1837     (let ((dx (- nx x1))
1838     (dy (- ny y1)))
1839     (multiple-value-prog1
1840     (call-next-method)
1841     (incf start-x dx)
1842     (incf start-y dy)
1843     (incf end-x dx)
1844     (incf end-y dy)
1845     ;(incf baseline dy)
1846     (loop for s in strings
1847     do (incf (slot-value s 'start-x) dx)))))))
1848 cvs 1.9
1849 adejneka 1.46 (defmethod replay-output-record ((record standard-text-displayed-output-record)
1850 moore 1.34 stream
1851 adejneka 1.21 &optional region (x-offset 0) (y-offset 0))
1852 adejneka 1.46 (declare (ignore region x-offset y-offset))
1853 tmoore 1.117 (with-slots (strings baseline max-height start-y wrapped)
1854 moore 1.57 record
1855 adejneka 1.47 (with-sheet-medium (medium stream) ;is sheet a sheet-with-medium-mixin? --GB
1856 moore 1.57 ;; FIXME:
1857     ;; 1. SLOT-VALUE...
1858     ;; 2. It should also save a "current line".
1859     (setf (slot-value stream 'baseline) baseline)
1860     (loop for substring in strings
1861     do (with-slots (start-x string)
1862     substring
1863     (setf (stream-cursor-position stream)
1864     (values start-x start-y))
1865 crhodes 1.127 ;; FIXME: a bit of an abstraction inversion. Should
1866     ;; the styled strings here not simply be output
1867     ;; records? Then we could just replay them and all
1868     ;; would be well. -- CSR, 20060528.
1869     (with-drawing-options (stream
1870     :ink (graphics-state-ink substring)
1871     :clipping-region (graphics-state-clip substring)
1872     :text-style (graphics-state-text-style substring))
1873     (stream-write-output stream string nil))))
1874 moore 1.57 (when wrapped ; FIXME
1875     (draw-rectangle* medium
1876     (+ wrapped 0) start-y
1877     (+ wrapped 4) (+ start-y max-height)
1878     :ink +foreground-ink+
1879     :filled t)))))
1880 mikemac 1.1
1881 moore 1.34 (defmethod output-record-start-cursor-position
1882 adejneka 1.46 ((record standard-text-displayed-output-record))
1883 mikemac 1.1 (with-slots (start-x start-y) record
1884     (values start-x start-y)))
1885    
1886 moore 1.34 (defmethod output-record-end-cursor-position
1887 adejneka 1.46 ((record standard-text-displayed-output-record))
1888 mikemac 1.1 (with-slots (end-x end-y) record
1889     (values end-x end-y)))
1890    
1891 adejneka 1.46 (defmethod tree-recompute-extent
1892     ((text-record standard-text-displayed-output-record))
1893 crhodes 1.119 (with-standard-rectangle* (:y1 y1)
1894 tmoore 1.117 text-record
1895 crhodes 1.119 (with-slots (max-height left right)
1896 tmoore 1.117 text-record
1897     (setf (rectangle-edges* text-record)
1898 crhodes 1.119 (values (coordinate left)
1899     y1
1900     (coordinate right)
1901     (coordinate (+ y1 max-height))))))
1902 adejneka 1.47 text-record)
1903 adejneka 1.46
1904 adejneka 1.47 (defmethod add-character-output-to-text-record ; XXX OAOO with ADD-STRING-...
1905 adejneka 1.46 ((text-record standard-text-displayed-output-record)
1906     character text-style char-width height new-baseline)
1907 crhodes 1.119 (with-slots (strings baseline width max-height left right start-y end-x end-y medium)
1908 moore 1.57 text-record
1909     (if (and strings
1910     (let ((string (last1 strings)))
1911     (match-output-records string
1912     :text-style text-style
1913     :ink (medium-ink medium)
1914     :clipping-region (medium-clipping-region
1915     medium))))
1916     (vector-push-extend character (slot-value (last1 strings) 'string))
1917     (nconcf strings
1918     (list (make-instance
1919     'styled-string
1920     :start-x end-x
1921     :text-style text-style
1922     :medium medium ; pick up ink and clipping region
1923     :string (make-array 1 :initial-element character
1924     :element-type 'character
1925     :adjustable t
1926     :fill-pointer t)))))
1927 crhodes 1.119 (multiple-value-bind (minx miny maxx maxy)
1928     (text-bounding-rectangle* medium character :text-style text-style)
1929     (declare (ignore miny maxy))
1930     (setq baseline (max baseline new-baseline)
1931     ;; KLUDGE: note END-X here is really START-X of the new
1932     ;; string
1933     left (min left (+ end-x minx))
1934     end-x (+ end-x char-width)
1935     right (+ end-x (max 0 (- maxx char-width)))
1936     max-height (max max-height height)
1937     end-y (max end-y (+ start-y max-height))
1938     width (+ width char-width))))
1939 adejneka 1.46 (tree-recompute-extent text-record))
1940    
1941     (defmethod add-string-output-to-text-record
1942     ((text-record standard-text-displayed-output-record)
1943     string start end text-style string-width height new-baseline)
1944 hefner1 1.69 (setf end (or end (length string)))
1945 adejneka 1.46 (let ((length (max 0 (- end start))))
1946     (cond
1947 moore 1.57 ((eql length 1)
1948 adejneka 1.47 (add-character-output-to-text-record text-record