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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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