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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5