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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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