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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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