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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.72 - (hide annotations)
Sun May 25 10:37:30 2003 UTC (10 years, 11 months ago) by gilbert
Branch: MAIN
Changes since 1.71: +37 -0 lines
Added INVOKE-WITH-ROOM-FOR-GRAPHICS.
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     (letf (((medium-transformation stream) +identity-transformation+))
564     (multiple-value-bind (x1 y1 x2 y2)
565     (output-record-hit-detection-rectangle* record)
566     (ecase state
567     (:highlight
568     (draw-rectangle* (sheet-medium stream) x1 y1 x2 y2
569 adejneka 1.52 :filled nil :ink +foreground-ink+)) ; XXX +FLIPPING-INK+?
570 adejneka 1.46 (:unhighlight
571     (draw-rectangle* (sheet-medium stream) x1 y1 x2 y2
572 adejneka 1.52 :filled nil :ink +background-ink+)))))) ; XXX +FLIPPING-INK+?
573 rouanet 1.11
574 adejneka 1.46 ;;; 16.2.2. The Output Record "Database" Protocol
575     (defmethod output-record-children ((record basic-output-record))
576     nil)
577 mikemac 1.1
578 adejneka 1.46 (defmethod add-output-record (child (record basic-output-record))
579     (declare (ignore child))
580     (error "Cannot add a child to ~S." record))
581 rouanet 1.11
582 adejneka 1.47 (defmethod add-output-record :before (child (record compound-output-record))
583     (let ((parent (output-record-parent child)))
584     (when parent
585     (restart-case
586     (error "~S already has a parent ~S." child parent)
587     (delete ()
588     :report "Delete from the old parent."
589     (delete-output-record child parent))))))
590    
591 adejneka 1.46 (defmethod add-output-record :after (child (record compound-output-record))
592 rouanet 1.11 (recompute-extent-for-new-child record child))
593    
594 adejneka 1.46 (defmethod delete-output-record (child (record basic-output-record)
595     &optional (errorp t))
596     (declare (ignore child))
597     (when errorp (error "Cannot delete a child from ~S." record)))
598 mikemac 1.1
599 adejneka 1.46 (defmethod delete-output-record :after (child (record compound-output-record)
600     &optional (errorp t))
601 rouanet 1.11 (declare (ignore errorp))
602     (with-bounding-rectangle* (x1 y1 x2 y2) child
603     (recompute-extent-for-changed-child record child x1 y1 x2 y2)))
604    
605 adejneka 1.46 (defmethod clear-output-record ((record basic-output-record))
606     (error "Cannot clear ~S." record))
607    
608     (defmethod clear-output-record :after ((record compound-output-record))
609     (with-slots (x y x1 y1 x2 y2) record
610     (setf x1 x y1 y
611     x2 x y2 y)))
612    
613     (defmethod output-record-count ((record basic-output-record))
614     0)
615 mikemac 1.1
616 adejneka 1.46 (defmethod map-over-output-records
617     (function (record basic-output-record)
618     &optional (x-offset 0) (y-offset 0)
619     &rest function-args)
620     (declare (ignore function x-offset y-offset function-args))
621     nil)
622 mikemac 1.1
623 adejneka 1.46 ;;; This needs to work in "most recently added last" order. Is this
624     ;;; implementation right? -- APD, 2002-06-13
625     #+nil
626 moore 1.39 (defmethod map-over-output-records
627 adejneka 1.46 (function (record compound-output-record)
628 moore 1.35 &optional (x-offset 0) (y-offset 0)
629     &rest function-args)
630     (declare (ignore x-offset y-offset))
631 adejneka 1.46 (map nil (lambda (child) (apply function child function-args))
632     (output-record-children record)))
633    
634     (defmethod map-over-output-records-containing-position
635     (function (record basic-output-record) x y
636     &optional (x-offset 0) (y-offset 0)
637     &rest function-args)
638     (declare (ignore function x y x-offset y-offset function-args))
639     nil)
640 moore 1.35
641 adejneka 1.46 ;;; This needs to work in "most recently added first" order. Is this
642     ;;; implementation right? -- APD, 2002-06-13
643     #+nil
644 moore 1.35 (defmethod map-over-output-records-containing-position
645 adejneka 1.46 (function (record compound-output-record) x y
646 moore 1.35 &optional (x-offset 0) (y-offset 0)
647     &rest function-args)
648 moore 1.36 (declare (ignore x-offset y-offset))
649 adejneka 1.46 (map nil
650     (lambda (child)
651     (when (and (multiple-value-bind (min-x min-y max-x max-y)
652 moore 1.39 (output-record-hit-detection-rectangle* child)
653     (and (<= min-x x max-x) (<= min-y y max-y)))
654     (output-record-refined-position-test child x y))
655 adejneka 1.46 (apply function child function-args)))
656     (output-record-children record)))
657    
658     (defmethod map-over-output-records-overlapping-region
659     (function (record basic-output-record) region
660     &optional (x-offset 0) (y-offset 0)
661     &rest function-args)
662     (declare (ignore function region x-offset y-offset function-args))
663     nil)
664 mikemac 1.1
665 adejneka 1.46 ;;; This needs to work in "most recently added last" order. Is this
666     ;;; implementation right? -- APD, 2002-06-13
667     #+nil
668 moore 1.35 (defmethod map-over-output-records-overlapping-region
669 adejneka 1.46 (function (record compound-output-record) region
670 moore 1.35 &optional (x-offset 0) (y-offset 0)
671     &rest function-args)
672     (declare (ignore x-offset y-offset))
673 adejneka 1.46 (map nil
674     (lambda (child) (when (region-intersects-region-p region child)
675     (apply function child function-args)))
676     (output-record-children record)))
677 mikemac 1.1
678 adejneka 1.46 ;;; 16.2.3. Output Record Change Notification Protocol
679 moore 1.39 (defmethod recompute-extent-for-new-child
680 adejneka 1.46 ((record compound-output-record) child)
681 rouanet 1.11 (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2) record
682 adejneka 1.46 (with-slots (parent x1 y1 x2 y2) record
683     (if (= 1 (length (output-record-children record)))
684 moore 1.34 (setf (values x1 y1 x2 y2) (bounding-rectangle* child))
685     (with-bounding-rectangle* (x1-child y1-child x2-child y2-child) child
686     (minf x1 x1-child)
687     (minf y1 y1-child)
688     (maxf x2 x2-child)
689     (maxf y2 y2-child)))
690 rouanet 1.11 (when parent
691 moore 1.34 (recompute-extent-for-changed-child parent record
692 adejneka 1.47 old-x1 old-y1 old-x2 old-y2))))
693     record)
694 mikemac 1.1
695 adejneka 1.46 (defmethod %tree-recompute-extent* ((record compound-output-record))
696     ;; Internal helper function
697 moore 1.34 (let ((new-x1 0)
698     (new-y1 0)
699     (new-x2 0)
700     (new-y2 0)
701     (first-time t))
702     (map-over-output-records
703 adejneka 1.46 (lambda (child)
704     (if first-time
705     (progn
706     (multiple-value-setq (new-x1 new-y1 new-x2 new-y2)
707     (bounding-rectangle* child))
708     (setq first-time nil))
709     (with-bounding-rectangle* (cx1 cy1 cx2 cy2) child
710     (minf new-x1 cx1)
711     (minf new-y1 cy1)
712     (maxf new-x2 cx2)
713     (maxf new-y2 cy2))))
714 moore 1.34 record)
715     (if first-time
716 adejneka 1.46 (with-slots (x y) record
717     (values x y x y))
718 moore 1.34 (values new-x1 new-y1 new-x2 new-y2))))
719    
720     (defmethod recompute-extent-for-changed-child
721 adejneka 1.46 ((record compound-output-record) changed-child
722 moore 1.34 old-min-x old-min-y old-max-x old-max-y)
723     ;; If the child's old and new bbox lies entirely within the record's bbox
724     ;; then no change need be made to the record's bbox. Otherwise, if some part
725     ;; of the child's bbox was on the record's bbox and is now inside, examine
726     ;; all the children to determine the correct new bbox.
727     (with-slots (x1 y1 x2 y2) record
728     (with-bounding-rectangle* (child-x1 child-y1 child-x2 child-y2)
729     changed-child
730 adejneka 1.46 (unless (and (> x1 old-min-x) (> x1 child-x1)
731     (> y1 old-min-y) (> y1 child-y1)
732     (< x2 old-max-x) (< x2 child-x2)
733     (< y2 old-max-y) (< y2 child-y2))
734 moore 1.34 ;; Don't know if changed-child has been deleted or what, so go through
735     ;; all the children and construct the updated bbox.
736 adejneka 1.47 (setf (values x1 y1 x2 y2) (%tree-recompute-extent* record)))))
737     record)
738 moore 1.34
739 adejneka 1.46 (defmethod recompute-extent-for-changed-child :around
740     ((record compound-output-record) child
741     old-min-x old-min-y old-max-x old-max-y)
742     (declare (ignore child old-min-x old-min-y old-max-x old-max-y))
743     (unless (slot-value record 'in-moving-p)
744 adejneka 1.47 (let ((old-rectangle (multiple-value-call #'make-bounding-rectangle
745     (bounding-rectangle* record))))
746 adejneka 1.46 (call-next-method)
747     (with-slots (parent x1 y1 x2 y2) record
748     (when (and parent (not (region-equal old-rectangle record)))
749 adejneka 1.47 (multiple-value-call #'recompute-extent-for-changed-child
750     (values parent record)
751     (bounding-rectangle* old-rectangle))))))
752     record)
753 adejneka 1.46
754     (defmethod tree-recompute-extent ((record compound-output-record))
755 moore 1.34 (with-slots (x1 y1 x2 y2) record
756 adejneka 1.47 (setf (values x1 y1 x2 y2) (%tree-recompute-extent* record)))
757     record)
758 mikemac 1.1
759 adejneka 1.46 (defmethod tree-recompute-extent :around ((record compound-output-record))
760 adejneka 1.47 (let ((old-rectangle (multiple-value-call #'make-bounding-rectangle
761     (bounding-rectangle* record))))
762 adejneka 1.22 (call-next-method)
763     (with-slots (parent x1 y1 x2 y2) record
764 adejneka 1.41 (when (and parent (not (region-equal old-rectangle record)))
765 adejneka 1.47 (recompute-extent-for-changed-child parent record x1 y1 x2 y2))))
766     record)
767 mikemac 1.1
768 adejneka 1.46 ;;; 16.3.1. Standard output record classes
769 mikemac 1.1
770 adejneka 1.46 (defclass standard-sequence-output-record (compound-output-record)
771     ((children :initform (make-array 8 :adjustable t :fill-pointer 0)
772     :reader output-record-children)))
773 moore 1.34
774 adejneka 1.46 (defmethod add-output-record (child (record standard-sequence-output-record))
775 adejneka 1.47 (vector-push-extend child (output-record-children record))
776     (setf (output-record-parent child) record))
777 mikemac 1.1
778 adejneka 1.46 (defmethod delete-output-record (child (record standard-sequence-output-record)
779     &optional (errorp t))
780     (with-slots (children) record
781     (let ((pos (position child children :test #'eq)))
782     (if (null pos)
783     (when errorp
784     (error "~S is not a child of ~S" child record))
785     (progn
786     (setq children (replace children children
787     :start1 pos
788     :start2 (1+ pos)))
789 adejneka 1.47 (decf (fill-pointer children))
790     (setf (output-record-parent child) nil))))))
791 mikemac 1.1
792 adejneka 1.46 (defmethod clear-output-record ((record standard-sequence-output-record))
793 adejneka 1.47 (let ((children (output-record-children record)))
794     (map 'nil (lambda (child) (setf (output-record-parent child) nil))
795     children)
796 adejneka 1.46 (fill children nil)
797     (setf (fill-pointer children) 0)))
798 rouanet 1.11
799 adejneka 1.46 (defmethod output-record-count ((record standard-sequence-output-record))
800     (length (output-record-children record)))
801 rouanet 1.11
802 adejneka 1.46 (defmethod map-over-output-records
803     (function (record standard-sequence-output-record)
804     &optional (x-offset 0) (y-offset 0)
805     &rest function-args)
806     "Applies FUNCTION to all children in the order they were added."
807     (declare (ignore x-offset y-offset))
808     (loop with children = (output-record-children record)
809     for child across children
810     do (apply function child function-args)))
811 mikemac 1.1
812 adejneka 1.46 (defmethod map-over-output-records-containing-position
813     (function (record standard-sequence-output-record) x y
814     &optional (x-offset 0) (y-offset 0)
815     &rest function-args)
816     "Applies FUNCTION to children, containing (X,Y), in the reversed
817     order they were added."
818     (declare (ignore x-offset y-offset))
819     (loop with children = (output-record-children record)
820     for i from (1- (length children)) downto 0
821     for child = (aref children i)
822     when (and (multiple-value-bind (min-x min-y max-x max-y)
823     (output-record-hit-detection-rectangle* child)
824     (and (<= min-x x max-x) (<= min-y y max-y)))
825     (output-record-refined-position-test child x y))
826     do (apply function child function-args)))
827 cvs 1.7
828 adejneka 1.46 (defmethod map-over-output-records-overlapping-region
829     (function (record standard-sequence-output-record) region
830     &optional (x-offset 0) (y-offset 0)
831     &rest function-args)
832     "Applies FUNCTION to children, overlapping REGION, in the order they
833     were added."
834     (declare (ignore x-offset y-offset))
835     (loop with children = (output-record-children record)
836     for child across children
837     when (region-intersects-region-p region child)
838     do (apply function child function-args)))
839 rouanet 1.11
840 adejneka 1.46 ;;; XXX bogus for now.
841     (defclass standard-tree-output-record (standard-sequence-output-record)
842     (
843     ))
844 mikemac 1.1
845 moore 1.57 (defmethod match-output-records ((record t) &rest args)
846     (apply #'match-output-records-1 record args))
847    
848     ;;; Factor out the graphics state portions of the output records so
849     ;;; they can be manipulated seperately e.g., by incremental
850     ;;; display. The individual slots of a graphics state are factored into mixin
851     ;;; classes so that each output record can capture only the state that it needs.
852     ;;; -- moore
853    
854     ;;; It would be appealing to define a setf method, e.g. (setf
855     ;;; medium-graphics-state), for setting a medium's state from a graphics state
856     ;;; object, but that would require us to define a medium-graphics-state reader
857     ;;; that would cons a state object. I don't want to do that.
858    
859     (defclass graphics-state ()
860     ()
861     (:documentation "Stores those parts of the medium/stream graphics state
862     that need to be restored when drawing an output record"))
863    
864     (defgeneric set-medium-graphics-state (state medium)
865     (:documentation "Sets the MEDIUM graphics state from STATE"))
866    
867     (defmethod set-medium-graphics-state (state medium)
868     (declare (ignore medium))
869     state)
870    
871     (defmethod set-medium-graphics-state (state (stream output-recording-stream))
872     (with-sheet-medium (medium stream)
873     (set-medium-graphics-state state medium)))
874    
875     (defclass gs-ink-mixin (graphics-state)
876     ((ink :initarg :ink :accessor graphics-state-ink)))
877    
878     (defmethod initialize-instance :after ((obj gs-ink-mixin)
879     &key (stream nil)
880     (medium (when stream
881     (sheet-medium stream))))
882     (when (and medium (not (slot-boundp obj 'ink)))
883     (setf (slot-value obj 'ink) (medium-ink medium))))
884    
885     (defmethod set-medium-graphics-state :after ((state gs-ink-mixin) medium)
886     (setf (medium-ink medium) (graphics-state-ink state)))
887    
888 moore 1.64 (defrecord-predicate gs-ink-mixin (ink)
889     (if-supplied ink
890     (design-equalp (slot-value record 'ink) ink)))
891 moore 1.57
892     (defclass gs-clip-mixin (graphics-state)
893     ((clip :initarg :clipping-region :accessor graphics-state-clip
894     :documentation "Clipping region in stream coordinates.")))
895    
896    
897     (defmethod initialize-instance :after ((obj gs-clip-mixin)
898     &key (stream nil)
899     (medium (when stream
900     (sheet-medium stream))))
901     (when medium
902     (with-slots (clip)
903     obj
904     (let ((clip-region (if (slot-boundp obj 'clip)
905     (region-intersection (medium-clipping-region
906     medium)
907     clip)
908     (medium-clipping-region medium))))
909     (setq clip (transform-region (medium-transformation medium)
910     clip-region))))))
911    
912     (defmethod set-medium-graphics-state :after ((state gs-clip-mixin) medium)
913 gilbert 1.59 ;;
914     ;; This definition is kind of wrong. When output records are about to
915     ;; be replayed only a certain region of the stream should be affected.[1]
916     ;; Therefore I disabled this code, since this way only breaks the
917     ;; [not very frequent case] that the output record actually contains
918     ;; a clipping region different from +everywhere+, while having it in
919     ;; breaks redisplay of streams in just about every case.
920     ;;
921     ;; Most notably Closure is affected by this, as it does the equivalent of
922     ;; (draw-rectangle* medium 0 0 800 200 :ink +white+ :filled t)
923     ;; (draw-text* medium "Hello" 100 100)
924     ;;
925     ;; Having this code in a redisplay on the region
926     ;; (make-rectangle* 0 0 50 50) fills the drawing pane with a white
927     ;; rectangle obscuring the text.
928     ;;
929     ;; [1] it is of course debatable where this extra clipping because
930     ;; of redisplay should come from. Should replay-output-record set it
931     ;; up? Should handle-repaint do so?
932     ;;
933     ;; --GB 2003-03-14
934 mikemac 1.61 #+nil
935 moore 1.57 (setf (medium-clipping-region medium) (graphics-state-clip state)))
936    
937     (defmethod match-output-records-1 and ((record gs-clip-mixin)
938     &key (clip nil clipp))
939     (or clipp
940     (region-equal (graphics-state-clip record) clip)))
941    
942 moore 1.64 (defrecord-predicate gs-clip-mixin ((:clipping-region clip))
943     (if-supplied clip
944     (region-equal (slot-value record 'clip) clip)))
945    
946 adejneka 1.46 ;;; 16.3.2. Graphics Displayed Output Records
947 moore 1.57 (defclass standard-displayed-output-record (gs-clip-mixin gs-ink-mixin
948     basic-output-record
949 adejneka 1.46 displayed-output-record)
950 moore 1.57 ((ink :reader displayed-output-record-ink))
951 adejneka 1.46 (:documentation "Implementation class for DISPLAYED-OUTPUT-RECORD."))
952 mikemac 1.1
953 moore 1.57 (defclass gs-line-style-mixin (graphics-state)
954     ((line-style :initarg :line-style :accessor graphics-state-line-style)))
955    
956     (defmethod initialize-instance :after ((obj gs-line-style-mixin)
957     &key (stream nil)
958     (medium (when stream
959     (sheet-medium stream))))
960     (when medium
961     (unless (slot-boundp obj 'line-style)
962     (setf (slot-value obj 'line-style) (medium-line-style medium)))))
963    
964     (defmethod set-medium-graphics-state :after ((state gs-line-style-mixin) medium)
965     (setf (medium-line-style medium) (graphics-state-line-style state)))
966    
967 moore 1.64 (defrecord-predicate gs-line-style-mixin (line-style)
968     (if-supplied line-style
969     (line-style-equalp (slot-value record 'line-style) line-style)))
970 moore 1.57
971     (defgeneric graphics-state-line-style-border (record medium)
972     (:method ((record gs-line-style-mixin) medium)
973     (/ (line-style-effective-thickness (graphics-state-line-style record)
974     medium)
975     2)))
976    
977     (defclass gs-text-style-mixin (graphics-state)
978     ((text-style :initarg :text-style :accessor graphics-state-text-style)))
979    
980     (defmethod initialize-instance :after ((obj gs-text-style-mixin)
981     &key (stream nil)
982     (medium (when stream
983     (sheet-medium stream))))
984     (when medium
985     (unless (slot-boundp obj 'text-style)
986     (setf (slot-value obj 'text-style) (medium-text-style medium)))))
987    
988     (defmethod set-medium-graphics-state :after ((state gs-text-style-mixin) medium)
989     (setf (medium-text-style medium) (graphics-state-text-style state)))
990    
991 moore 1.64 (defrecord-predicate gs-text-style-mixin (text-style)
992     (if-supplied text-style
993     (text-style-equalp (slot-value record 'text-style) text-style)))
994 moore 1.57
995 adejneka 1.46 (defclass standard-graphics-displayed-output-record
996 moore 1.57 (standard-displayed-output-record
997     graphics-displayed-output-record)
998     ())
999    
1000     (defmethod match-output-records-1 and
1001     ((record standard-displayed-output-record)
1002     &key (x1 nil x1-p) (y1 nil y1-p)
1003     (x2 nil x2-p) (y2 nil y2-p)
1004     (bounding-rectangle nil bounding-rectangle-p))
1005     (if bounding-rectangle-p
1006     (region-equal record bounding-rectangle)
1007     (multiple-value-bind (my-x1 my-y1 my-x2 my-y2)
1008     (bounding-rectangle* record)
1009     (and (or (null x1-p) (coordinate= my-x1 x1))
1010     (or (null y1-p) (coordinate= my-y1 y1))
1011     (or (null x2-p) (coordinate= my-x2 x2))
1012     (or (null y2-p) (coordinate= my-y2 y2))))))
1013    
1014 moore 1.64 (defmethod output-record-equal and ((record standard-displayed-output-record)
1015     (record2 standard-displayed-output-record))
1016     (region-equal record record2))
1017    
1018 moore 1.57 ;;; This is an around method so that more specific before methods can be
1019     ;;; defined for the various mixin classes, that modify the state after it has
1020     ;;; been set in the graphics state.
1021    
1022     (defmethod replay-output-record :around
1023     ((record standard-displayed-output-record) stream
1024     &optional region x-offset y-offset)
1025     (declare (ignore region x-offset y-offset))
1026     (set-medium-graphics-state record stream)
1027     (call-next-method))
1028    
1029     (defclass coord-seq-mixin ()
1030     ((coord-seq :accessor coord-seq :initarg :coord-seq))
1031     (:documentation "Mixin class that implements methods for records that contain
1032     sequences of coordinates."))
1033    
1034     (defun coord-seq-bounds (coord-seq border)
1035     (let* ((min-x (elt coord-seq 0))
1036     (min-y (elt coord-seq 1))
1037     (max-x min-x)
1038     (max-y min-y))
1039     (do-sequence ((x y) coord-seq)
1040     (minf min-x x)
1041     (minf min-y y)
1042     (maxf max-x x)
1043     (maxf max-y y))
1044     (values (- min-x border) (- min-y border)
1045     (+ max-x border) (+ max-y border))))
1046    
1047     (defmethod initialize-instance :after ((record coord-seq-mixin) &key)
1048     (let ((medium (sheet-medium (slot-value record 'stream))))
1049     (with-slots (coord-seq)
1050     record
1051     (setf coord-seq
1052     (transform-position-sequence 'vector
1053     (medium-transformation medium)
1054     coord-seq)))))
1055    
1056     ;;; x1, y1 slots must exist in class...
1057 mikemac 1.1
1058 moore 1.57 (defmethod* (setf output-record-position) :around
1059     (nx ny (record coord-seq-mixin))
1060     (with-slots (x1 y1)
1061     record
1062     (let ((dx (- nx x1))
1063     (dy (- ny y1))
1064     (coords (slot-value record 'coord-seq)))
1065     (multiple-value-prog1
1066     (call-next-method)
1067     (loop for i from 0 below (length coords) by 2
1068     do (progn
1069     (incf (aref coords i) dx)
1070 gilbert 1.59 (incf (aref coords (1+ i)) dy)))))))
1071 moore 1.57
1072     (defmethod match-output-records-1 and ((record coord-seq-mixin)
1073     &key (coord-seq nil coord-seq-p))
1074     (or (null coord-seq-p)
1075     (let* ((my-coord-seq (slot-value record 'coord-seq))
1076     (len (length my-coord-seq)))
1077     (and (eql len (length coord-seq))
1078     (loop for elt1 across my-coord-seq
1079     for elt2 across coord-seq
1080     always (coordinate= elt1 elt2))))))
1081    
1082     (defmacro def-grecording (name ((&rest mixins) &rest args) &body body)
1083 gilbert 1.56 (let ((method-name (symbol-concat '#:medium- name '*))
1084 mikemac 1.63 (class-name (symbol-concat name '#:-output-record))
1085 adejneka 1.41 (medium (gensym "MEDIUM"))
1086 adejneka 1.46 (class-vars `((stream :initarg :stream)
1087     ,@(loop for arg in args
1088     collect `(,arg
1089     :initarg ,(intern (symbol-name arg)
1090     :keyword)))))
1091     (arg-list (loop for arg in args
1092     nconc `(,(intern (symbol-name arg) :keyword) ,arg))))
1093 cvs 1.10 `(progn
1094 moore 1.57 (defclass ,class-name (,@mixins standard-graphics-displayed-output-record)
1095 adejneka 1.46 ,class-vars)
1096 mikemac 1.1 (defmethod initialize-instance :after ((graphic ,class-name) &rest args)
1097     (declare (ignore args))
1098 moore 1.57 (with-slots (x1 y1 x2 y2
1099     stream ink clipping-region
1100     line-style text-style ,@args)
1101     graphic
1102 strandh 1.58 (let* ((medium (sheet-medium stream)))
1103 moore 1.57 (multiple-value-setq (x1 y1 x2 y2) (progn ,@body)))))
1104 rouanet 1.11 (defmethod ,method-name :around ((stream output-recording-stream) ,@args)
1105 adejneka 1.47 ;; XXX STANDARD-OUTPUT-RECORDING-STREAM ^?
1106 mikemac 1.1 (with-sheet-medium (medium stream)
1107 cvs 1.5 (when (stream-recording-p stream)
1108     (let ((record (make-instance ',class-name
1109     :stream stream
1110 adejneka 1.46 ,@arg-list)))
1111 rouanet 1.11 (stream-add-output-record stream record)))
1112 cvs 1.5 (when (stream-drawing-p stream)
1113     (call-next-method))))
1114 mikemac 1.1 (defmethod replay-output-record ((record ,class-name) stream
1115 rouanet 1.18 &optional (region +everywhere+)
1116     (x-offset 0) (y-offset 0))
1117 moore 1.57 (declare (ignore x-offset y-offset region))
1118     (with-slots (,@args) record
1119     (let ((,medium (sheet-medium stream))
1120 adejneka 1.41 ;; is sheet a sheet-with-medium-mixin? --GB
1121     )
1122 moore 1.57 ;; Graphics state is set up in :around method.
1123     (,method-name ,medium ,@args)))))))
1124 mikemac 1.1
1125 moore 1.57 (def-grecording draw-point ((gs-line-style-mixin) point-x point-y)
1126     (let ((border (graphics-state-line-style-border graphic medium)))
1127     (with-transformed-position ((medium-transformation medium) point-x point-y)
1128     (setf (slot-value graphic 'point-x) point-x
1129     (slot-value graphic 'point-y) point-y)
1130     (values (- point-x border)
1131     (- point-y border)
1132     (+ point-x border)
1133     (+ point-y border)))))
1134    
1135     (defmethod* (setf output-record-position) :around
1136     (nx ny (record draw-point-output-record))
1137     (with-slots (x1 y1 point-x point-y)
1138     record
1139     (let ((dx (- nx x1))
1140     (dy (- ny y1)))
1141     (multiple-value-prog1
1142     (call-next-method)
1143     (incf point-x dx)
1144     (incf point-y dy)))))
1145    
1146 moore 1.64 (defrecord-predicate draw-point-output-record (point-x point-y)
1147     (and (if-supplied point-x
1148     (coordinate= (slot-value record 'point-x) point-x))
1149     (if-supplied point-y
1150     (coordinate= (slot-value record 'point-y) point-y))))
1151 moore 1.57
1152     (def-grecording draw-points ((coord-seq-mixin gs-line-style-mixin) coord-seq)
1153     ;; coord-seq has already been transformed
1154     (let ((border (graphics-state-line-style-border graphic medium)))
1155     (coord-seq-bounds coord-seq border)))
1156    
1157     (def-grecording draw-line ((gs-line-style-mixin)
1158     point-x1 point-y1 point-x2 point-y2)
1159     (let ((transform (medium-transformation medium))
1160     (border (graphics-state-line-style-border graphic medium)))
1161     (with-transformed-position (transform point-x1 point-y1)
1162     (with-transformed-position (transform point-x2 point-y2)
1163     (setf (slot-value graphic 'point-x1) point-x1
1164     (slot-value graphic 'point-y1) point-y1
1165     (slot-value graphic 'point-x2) point-x2
1166     (slot-value graphic 'point-y2) point-y2)
1167     (values (- (min point-x1 point-x2) border)
1168     (- (min point-y1 point-y2) border)
1169     (+ (max point-x1 point-x2) border)
1170     (+ (max point-y1 point-y2) border))))))
1171    
1172     (defmethod* (setf output-record-position) :around
1173     (nx ny (record draw-line-output-record))
1174     (with-slots (x1 y1
1175     point-x1 point-y1 point-x2 point-y2)
1176     record
1177     (let ((dx (- nx x1))
1178     (dy (- ny y1)))
1179     (multiple-value-prog1
1180     (call-next-method)
1181     (incf point-x1 dx)
1182     (incf point-y1 dy)
1183     (incf point-x2 dx)
1184     (incf point-y2 dy)))))
1185    
1186 moore 1.64 (defrecord-predicate draw-line-output-record (point-x1 point-y1
1187     point-x2 point-y2)
1188     (and (if-supplied point-x1
1189     (coordinate= (slot-value record 'point-x1) point-x1))
1190     (if-supplied point-y1
1191     (coordinate= (slot-value record 'point-y1) point-y1))
1192     (if-supplied point-x2
1193     (coordinate= (slot-value record 'point-x2) point-x2))
1194     (if-supplied point-y2
1195     (coordinate= (slot-value record 'point-y2) point-y2))))
1196 moore 1.57
1197     (def-grecording draw-lines ((coord-seq-mixin gs-line-style-mixin) coord-seq)
1198     (let ((border (graphics-state-line-style-border graphic medium)))
1199     (coord-seq-bounds coord-seq border)))
1200    
1201 moore 1.64 ;;; (setf output-record-position) and predicates for draw-lines-output-record
1202     ;;; are taken care of by methods on superclasses.
1203    
1204 moore 1.57 ;;; Helper function
1205     (defun normalize-coords (dx dy &optional unit)
1206     (let ((norm (sqrt (+ (* dx dx) (* dy dy)))))
1207     (if unit
1208     (let ((scale (/ unit norm)))
1209     (values (* dx scale) (* dy scale)))
1210     (values (/ dx norm) (/ dy norm)))))
1211 mikemac 1.1
1212 adejneka 1.52 (defun polygon-record-bounding-rectangle
1213 moore 1.57 (coord-seq closed filled line-style border miter-limit)
1214 moore 1.54 (cond (filled
1215 moore 1.57 (coord-seq-bounds coord-seq 0))
1216 moore 1.54 ((eq (line-style-joint-shape line-style) :round)
1217 moore 1.57 (coord-seq-bounds coord-seq border))
1218     (t (let* ((x1 (svref coord-seq 0))
1219     (y1 (svref coord-seq 1))
1220     (min-x x1)
1221     (min-y y1)
1222     (max-x x1)
1223     (max-y y1)
1224     (len (length coord-seq)))
1225     (unless closed
1226     (setq min-x (- x1 border) min-y (- y1 border)
1227     max-x (+ x1 border) max-y (+ y1 border)))
1228     ;; Setup for iterating over the coordinate vector. If the polygon
1229     ;; is closed deal with the extra segment.
1230     (multiple-value-bind (initial-xp initial-yp
1231     final-xn final-yn
1232     initial-index final-index)
1233     (if closed
1234     (values (svref coord-seq (- len 2))
1235     (svref coord-seq (- len 1))
1236     x1 y1
1237     0 (- len 2))
1238     (values x1 y1
1239     (svref coord-seq (- len 2))
1240     (svref coord-seq (- len 1))
1241     2 (- len 4)))
1242     (ecase (line-style-joint-shape line-style)
1243     (:miter
1244     ;;FIXME: Remove successive positively proportional segments
1245     (loop with sin-limit = (sin (* 0.5 miter-limit))
1246     and xn and yn
1247     for i from initial-index to final-index by 2
1248     for xp = initial-xp then x
1249     for yp = initial-yp then y
1250     for x = (svref coord-seq i)
1251     for y = (svref coord-seq (1+ i))
1252     do (setf (values xn yn)
1253     (if (eql i final-index)
1254     (values final-xn final-yn)
1255     (values (svref coord-seq (+ i 2))
1256     (svref coord-seq (+ i
1257     3)))))
1258     (multiple-value-bind (ex1 ey1)
1259     (normalize-coords (- x xp) (- y yp))
1260     (multiple-value-bind (ex2 ey2)
1261     (normalize-coords (- x xn) (- y yn))
1262     (let* ((cos-a (+ (* ex1 ex2) (* ey1 ey2)))
1263     (sin-a/2 (sqrt (* 0.5 (- 1.0 cos-a)))))
1264     (if (< sin-a/2 sin-limit)
1265     (let ((nx (* border
1266     (max (abs ey1) (abs ey2))))
1267     (ny (* border
1268     (max (abs ex1) (abs ex2)))))
1269     (minf min-x (- x nx))
1270     (minf min-y (- y ny))
1271     (maxf max-x (+ x nx))
1272     (maxf max-y (+ y ny)))
1273     (let ((length (/ border sin-a/2)))
1274     (multiple-value-bind (dx dy)
1275     (normalize-coords (+ ex1 ex2)
1276     (+ ey1 ey2)
1277     length)
1278     (minf min-x (+ x dx))
1279     (minf min-y (+ y dy))
1280     (maxf max-x (+ x dx))
1281     (maxf max-y (+ y dy))))))))))
1282     ((:bevel :none)
1283     (loop with xn and yn
1284     for i from initial-index to final-index by 2
1285     for xp = initial-xp then x
1286     for yp = initial-yp then y
1287     for x = (svref coord-seq i)
1288     for y = (svref coord-seq (1+ i))
1289     do (setf (values xn yn)
1290     (if (eql i final-index)
1291     (values final-xn final-yn)
1292     (values (svref coord-seq (+ i 2))
1293     (svref coord-seq (+ i
1294     3)))))
1295     (multiple-value-bind (ex1 ey1)
1296     (normalize-coords (- x xp) (- y yp))
1297     (multiple-value-bind (ex2 ey2)
1298     (normalize-coords (- x xn) (- y yn))
1299     (let ((nx (* border (max (abs ey1) (abs ey2))))
1300     (ny (* border (max (abs ex1) (abs ex2)))))
1301     (minf min-x (- x nx))
1302     (minf min-y (- y ny))
1303     (maxf max-x (+ x nx))
1304     (maxf max-y (+ y ny))))))))
1305     (unless closed
1306     (multiple-value-bind (x y)
1307     (values (svref coord-seq final-index)
1308     (svref coord-seq (1+ final-index)))
1309     (minf min-x (- x border))
1310     (minf min-y (- y border))
1311     (maxf max-x (+ x border))
1312     (maxf max-y (+ y border)))))
1313     (values min-x min-y max-x max-y)))))
1314    
1315     (def-grecording draw-polygon ((coord-seq-mixin gs-line-style-mixin)
1316     coord-seq closed filled)
1317     (let ((border (graphics-state-line-style-border graphic medium)))
1318     (polygon-record-bounding-rectangle
1319     coord-seq closed filled line-style border (medium-miter-limit medium))))
1320    
1321 moore 1.64 (defrecord-predicate draw-polygon-output-record (closed filled)
1322     (and (if-supplied closed
1323     (eql (slot-value record 'closed) closed))
1324     (if-supplied filled
1325     (eql (slot-value record 'filled) filled))))
1326 moore 1.57
1327     (def-grecording draw-rectangle ((gs-line-style-mixin)
1328     left top right bottom filled)
1329     (let ((border (graphics-state-line-style-border graphic medium)))
1330     (polygon-record-bounding-rectangle
1331     (vector left top left bottom right bottom right top)
1332     t filled line-style border
1333     (medium-miter-limit medium))))
1334    
1335     (defmethod* (setf output-record-position) :around
1336     (nx ny (record draw-rectangle-output-record))
1337     (with-slots (x1 y1
1338     left top right bottom)
1339     record
1340     (let ((dx (- nx x1))
1341     (dy (- ny y1)))
1342     (multiple-value-prog1
1343     (call-next-method)
1344     (incf left dx)
1345     (incf top dy)
1346     (incf right dx)
1347     (incf bottom dy)))))
1348    
1349 moore 1.64 (defrecord-predicate draw-rectangle-output-record (left top right bottom filled)
1350     (and (if-supplied left
1351     (coordinate= (slot-value record 'left) left))
1352     (if-supplied top
1353     (coordinate= (slot-value record 'top) top))
1354     (if-supplied right
1355     (coordinate= (slot-value record 'right) right))
1356     (if-supplied bottom
1357     (coordinate= (slot-value record 'bottom) bottom))
1358     (if-supplied filled
1359     (eql (slot-value record 'filled) filled))))
1360 mikemac 1.1
1361 moore 1.57 (def-grecording draw-ellipse ((gs-line-style-mixin)
1362     center-x center-y
1363 mikemac 1.1 radius-1-dx radius-1-dy radius-2-dx radius-2-dy
1364     start-angle end-angle filled)
1365 adejneka 1.44 (multiple-value-bind (min-x min-y max-x max-y)
1366 moore 1.57 (bounding-rectangle* (make-ellipse* center-x center-y
1367     radius-1-dx radius-1-dy
1368     radius-2-dx radius-2-dy
1369     :start-angle start-angle
1370     :end-angle end-angle))
1371 adejneka 1.44 (if filled
1372     (values min-x min-y max-x max-y)
1373 moore 1.57 (let ((border (graphics-state-line-style-border graphic medium)))
1374     (values (- min-x border)
1375     (- min-y border)
1376     (+ max-x border)
1377     (+ max-y border))))))
1378    
1379     (defmethod* (setf output-record-position) :around
1380     (nx ny (record draw-ellipse-output-record))
1381     (with-slots (x1 y1 center-x center-y)
1382     record
1383     (let ((dx (- nx x1))
1384     (dy (- ny y1)))
1385     (multiple-value-prog1
1386     (call-next-method)
1387     (incf center-x dx)
1388     (incf center-y dy)))))
1389    
1390 moore 1.64 (defrecord-predicate draw-ellipse-output-record (center-x center-y)
1391     (and (if-supplied center-x
1392 moore 1.57 (coordinate= (slot-value record 'center-x) center-x))
1393 moore 1.64 (if-supplied center-y
1394 moore 1.57 (coordinate= (slot-value record 'center-y) center-y))))
1395 rouanet 1.11
1396 moore 1.57 (def-grecording draw-text ((gs-text-style-mixin) string point-x point-y start end
1397 rouanet 1.11 align-x align-y toward-x toward-y transform-glyphs)
1398 adejneka 1.44 ;; FIXME!!! Text direction.
1399 adejneka 1.43 ;; Multiple lines?
1400 moore 1.57 (let* ((text-style (graphics-state-text-style graphic))
1401 moore 1.67 (width (if (characterp string)
1402     (stream-character-width stream string :text-style text-style)
1403     (stream-string-width stream string
1404     :start start :end end
1405     :text-style text-style)) )
1406 strandh 1.26 (ascent (text-style-ascent text-style (sheet-medium stream)))
1407     (descent (text-style-descent text-style (sheet-medium stream)))
1408 rouanet 1.11 (height (+ ascent descent))
1409     left top right bottom)
1410     (ecase align-x
1411     (:left (setq left point-x
1412     right (+ point-x width)))
1413     (:right (setq left (- point-x width)
1414     right point-x))
1415     (:center (setq left (- point-x (round width 2))
1416     right (+ point-x (round width 2)))))
1417     (ecase align-y
1418 adejneka 1.43 (:baseline (setq top (- point-y ascent)
1419 rouanet 1.11 bottom (+ point-y descent)))
1420     (:top (setq top point-y
1421     bottom (+ point-y height)))
1422     (:bottom (setq top (- point-y height)
1423     bottom point-y))
1424     (:center (setq top (- point-y (floor height 2))
1425     bottom (+ point-y (ceiling height 2)))))
1426     (values left top right bottom)))
1427 mikemac 1.1
1428 moore 1.57 (defmethod* (setf output-record-position) :around
1429     (nx ny (record draw-text-output-record))
1430     (with-slots (x1 y1 point-x point-y toward-x toward-y)
1431     record
1432     (let ((dx (- nx x1))
1433     (dy (- ny y1)))
1434     (multiple-value-prog1
1435     (call-next-method)
1436     (incf point-x dx)
1437     (incf point-y dy)
1438     (incf toward-x dx)
1439     (incf toward-y dy)))))
1440    
1441 moore 1.64 (defrecord-predicate draw-text-output-record
1442     (string start end point-x point-y align-x align-y toward-x toward-y
1443     transform-glyphs)
1444     (and (if-supplied string
1445     (string= (slot-value record 'string) string))
1446     (if-supplied start
1447     (eql (slot-value record 'start) start))
1448     (if-supplied end
1449     (eql (slot-value record 'end) end))
1450     (if-supplied point-x
1451     (coordinate= (slot-value record 'point-x) point-x))
1452     (if-supplied point-y
1453     (coordinate= (slot-value record 'point-y) point-y))
1454     (if-supplied align-x
1455     (eq (slot-value record 'align-x) align-x))
1456     (if-supplied align-y
1457     (eq (slot-value record 'align-y) align-y))
1458     (if-supplied toward-x
1459     (coordinate= (slot-value record 'toward-x) toward-x))
1460     (if-supplied toward-y
1461     (coordinate= (slot-value record 'toward-y) toward-y))
1462     (if-supplied transform-glyphs
1463     (eq (slot-value record 'transform-glyphs) transform-glyphs))))
1464 moore 1.57
1465 adejneka 1.46 ;;; 16.3.3. Text Displayed Output Record
1466 adejneka 1.47
1467 moore 1.57 (defclass styled-string (gs-text-style-mixin gs-clip-mixin gs-ink-mixin)
1468 adejneka 1.47 ((start-x :initarg :start-x)
1469     (string :initarg :string :reader styled-string-string)))
1470 moore 1.34
1471 moore 1.64 (defmethod output-record-equal and ((record styled-string)
1472     (record2 styled-string))
1473     (and (coordinate= (slot-value record 'start-x)
1474     (slot-value record2 'start-x))
1475     (string= (slot-value record 'string)
1476     (slot-value record2 'string))))
1477    
1478 adejneka 1.46 (defclass standard-text-displayed-output-record
1479     (text-displayed-output-record standard-displayed-output-record)
1480 adejneka 1.47 ((initial-x1 :initarg :start-x)
1481     (initial-y1 :initarg :start-y)
1482     (strings :initform nil)
1483 mikemac 1.1 (baseline :initform 0)
1484 adejneka 1.22 (width :initform 0)
1485 mikemac 1.1 (max-height :initform 0)
1486 cvs 1.6 (start-x :initarg :start-x)
1487     (start-y :initarg :start-y)
1488 adejneka 1.47 (end-x :initarg :start-x)
1489     (end-y :initarg :start-y)
1490 cvs 1.8 (wrapped :initform nil
1491 moore 1.57 :accessor text-record-wrapped)
1492     (medium :initarg :medium :initform nil)))
1493    
1494     (defmethod initialize-instance :after
1495     ((obj standard-text-displayed-output-record) &key stream)
1496     (when stream
1497     (setf (slot-value obj 'medium) (sheet-medium stream))))
1498 mikemac 1.1
1499 moore 1.64 ;;; Forget match-output-records-1 for standard-text-displayed-output-record; it
1500     ;;; doesn't make much sense because these records have state that is not
1501     ;;; initialized via initargs.
1502    
1503     (defmethod output-record-equal and
1504     ((record standard-text-displayed-output-record)
1505     (record2 standard-text-displayed-output-record))
1506     (with-slots
1507     (initial-x1 initial-y1 start-x start-y end-x end-y wrapped strings)
1508     record2
1509     (and (coordinate= (slot-value record 'initial-x1) initial-x1)
1510     (coordinate= (slot-value record 'initial-y1) initial-y1)
1511     (coordinate= (slot-value record 'start-x) start-x)
1512     (coordinate= (slot-value record 'start-y) start-y)
1513     (coordinate= (slot-value record 'end-x) end-x)
1514     (coordinate= (slot-value record 'end-y) end-y)
1515     (eq (slot-value record 'wrapped) wrapped)
1516     (coordinate= (slot-value record 'baseline)
1517     (slot-value record2 'baseline))
1518     (eql (length (slot-value record 'strings)) (length strings));XXX
1519     (loop for s1 in (slot-value record 'strings)
1520     for s2 in strings
1521 mikemac 1.65 always (output-record-equal s1 s2)))))
1522 moore 1.64
1523 adejneka 1.46 (defmethod print-object ((self standard-text-displayed-output-record) stream)
1524 cvs 1.8 (print-unreadable-object (self stream :type t :identity t)
1525 adejneka 1.47 (with-slots (start-x start-y strings) self
1526     (format stream "~D,~D ~S"
1527     start-x start-y
1528     (mapcar #'styled-string-string strings)))))
1529 mikemac 1.1
1530 moore 1.34 (defmethod* (setf output-record-position) :before
1531 adejneka 1.46 (nx ny (record standard-text-displayed-output-record))
1532 moore 1.57 (with-slots (x1 y1 start-x start-y end-x end-y strings) record
1533 adejneka 1.46 (let ((dx (- nx x1))
1534     (dy (- ny y1)))
1535 rouanet 1.23 (incf start-x dx)
1536     (incf start-y dy)
1537     (incf end-x dx)
1538 moore 1.57 (incf end-y dy)
1539     (loop for s in strings
1540     do (incf (slot-value s 'start-x) dx)))))
1541 cvs 1.9
1542 adejneka 1.46 (defmethod replay-output-record ((record standard-text-displayed-output-record)
1543 moore 1.34 stream
1544 adejneka 1.21 &optional region (x-offset 0) (y-offset 0))
1545 adejneka 1.46 (declare (ignore region x-offset y-offset))
1546 moore 1.57 (with-slots (strings baseline max-height start-y wrapped x1 y1)
1547     record
1548 adejneka 1.47 (with-sheet-medium (medium stream) ;is sheet a sheet-with-medium-mixin? --GB
1549 moore 1.57 ;; FIXME:
1550     ;; 1. SLOT-VALUE...
1551     ;; 2. It should also save a "current line".
1552     (setf (slot-value stream 'baseline) baseline)
1553     (loop for substring in strings
1554     do (with-slots (start-x string)
1555     substring
1556     (setf (stream-cursor-position stream)
1557     (values start-x start-y))
1558     (set-medium-graphics-state substring medium)
1559 moore 1.67 (stream-write-output stream string)))
1560 moore 1.57 (when wrapped ; FIXME
1561     (draw-rectangle* medium
1562     (+ wrapped 0) start-y
1563     (+ wrapped 4) (+ start-y max-height)
1564     :ink +foreground-ink+
1565     :filled t)))))
1566 mikemac 1.1
1567 moore 1.34 (defmethod output-record-start-cursor-position
1568 adejneka 1.46 ((record standard-text-displayed-output-record))
1569 mikemac 1.1 (with-slots (start-x start-y) record
1570     (values start-x start-y)))
1571    
1572 moore 1.34 (defmethod output-record-end-cursor-position
1573 adejneka 1.46 ((record standard-text-displayed-output-record))
1574 mikemac 1.1 (with-slots (end-x end-y) record
1575     (values end-x end-y)))
1576    
1577 adejneka 1.46 (defmethod tree-recompute-extent
1578     ((text-record standard-text-displayed-output-record))
1579     (with-slots (parent x1 y1 x2 y2 width max-height) text-record
1580     (setq x2 (coordinate (+ x1 width))
1581 adejneka 1.47 y2 (coordinate (+ y1 max-height))))
1582     text-record)
1583 adejneka 1.46
1584 adejneka 1.47 (defmethod add-character-output-to-text-record ; XXX OAOO with ADD-STRING-...
1585 adejneka 1.46 ((text-record standard-text-displayed-output-record)
1586     character text-style char-width height new-baseline)
1587 moore 1.57 (with-slots (strings baseline width max-height start-y end-x end-y medium)
1588     text-record
1589     (if (and strings
1590     (let ((string (last1 strings)))
1591     (match-output-records string
1592     :text-style text-style
1593     :ink (medium-ink medium)
1594     :clipping-region (medium-clipping-region
1595     medium))))
1596     (vector-push-extend character (slot-value (last1 strings) 'string))
1597     (nconcf strings
1598     (list (make-instance
1599     'styled-string
1600     :start-x end-x
1601     :text-style text-style
1602     :medium medium ; pick up ink and clipping region
1603     :string (make-array 1 :initial-element character
1604     :element-type 'character
1605     :adjustable t
1606     :fill-pointer t)))))
1607     (setq baseline (max baseline new-baseline)
1608     end-x (+ end-x char-width)
1609     max-height (max max-height height)
1610     end-y (max end-y (+ start-y max-height))
1611     width (+ width char-width)))
1612 adejneka 1.46 (tree-recompute-extent text-record))
1613    
1614     (defmethod add-string-output-to-text-record
1615     ((text-record standard-text-displayed-output-record)
1616     string start end text-style string-width height new-baseline)
1617 hefner1 1.69 (setf end (or end (length string)))
1618 adejneka 1.46 (let ((length (max 0 (- end start))))
1619     (cond
1620 moore 1.57 ((eql length 1)
1621 adejneka 1.47 (add-character-output-to-text-record text-record
1622     (aref string start)
1623     text-style
1624     string-width height new-baseline))
1625 moore 1.57 (t (with-slots (strings baseline width max-height start-y end-x end-y
1626     medium)
1627     text-record
1628     (let ((styled-string (make-instance
1629     'styled-string
1630     :start-x end-x
1631     :text-style text-style
1632     :medium medium
1633 hefner1 1.69 :string (make-array length
1634 moore 1.57 :element-type 'character
1635     :adjustable t
1636     :fill-pointer t))))
1637     (nconcf strings (list styled-string))
1638     (replace (styled-string-string styled-string) string
1639     :start2 start :end2 end))
1640     (setq baseline (max baseline new-baseline)
1641     end-x (+ end-x string-width)
1642     max-height (max max-height height)
1643     end-y (max end-y (+ start-y max-height))
1644     width (+ width string-width)))
1645 adejneka 1.47 (tree-recompute-extent text-record)))))
1646 adejneka 1.46
1647 moore 1.34 (defmethod text-displayed-output-record-string
1648 adejneka 1.46 ((record standard-text-displayed-output-record))
1649     (with-output-to-string (result)
1650     (with-slots (strings) record
1651     (loop for (nil nil substring) in strings
1652     do (write-string substring result)))))
1653    
1654     ;;; 16.3.4. Top-Level Output Records
1655     (defclass stream-output-history-mixin ()
1656     ())
1657    
1658     (defclass standard-sequence-output-history
1659     (standard-sequence-output-record stream-output-history-mixin)
1660     ())
1661 cvs 1.5
1662 adejneka 1.46 (defclass standard-tree-output-history
1663     (standard-tree-output-record stream-output-history-mixin)
1664 moore 1.34 ())
1665    
1666 adejneka 1.46 ;;; 16.4. Output Recording Streams
1667     (defclass standard-output-recording-stream (output-recording-stream)
1668     ((recording-p :initform t :reader stream-recording-p)
1669     (drawing-p :initform t :accessor stream-drawing-p)
1670     (output-history :initform (make-instance 'standard-tree-output-history)
1671     :reader stream-output-history)
1672     (current-output-record :accessor stream-current-output-record)
1673     (current-text-output-record :initform nil
1674     :accessor stream-current-text-output-record)
1675     (local-record-p :initform t
1676     :documentation "This flag is used for dealing with streams outputting strings char-by-char.")))
1677    
1678     (defmethod initialize-instance :after
1679     ((stream standard-output-recording-stream) &rest args)
1680     (declare (ignore args))
1681     (setf (stream-current-output-record stream) (stream-output-history stream)))
1682    
1683 moore 1.55 ;;; Used in initializing clim-stream-pane
1684    
1685     (defmethod reset-output-history ((stream
1686     standard-output-recording-stream))
1687     (setf (slot-value stream 'output-history)
1688     (make-instance 'standard-tree-output-history))
1689     (setf (stream-current-output-record stream) (stream-output-history stream)))
1690    
1691 adejneka 1.46 ;;; 16.4.1 The Output Recording Stream Protocol
1692     (defmethod (setf stream-recording-p)
1693     (recording-p (stream standard-output-recording-stream))
1694     (let ((old-val (slot-value stream 'recording-p)))
1695     (setf (slot-value stream 'recording-p) recording-p)
1696     (when (not (eq old-val recording-p))
1697     (stream-close-text-output-record stream))
1698     recording-p))
1699    
1700     (defmethod stream-add-output-record
1701     ((stream standard-output-recording-stream) record)
1702     (add-output-record record (stream-current-output-record stream)))
1703    
1704     (defmethod stream-replay
1705     ((stream standard-output-recording-stream) &optional region)
1706     (replay (stream-output-history stream) stream region))
1707    
1708 adejneka 1.47 (defun output-record-ancestor-p (ancestor child)
1709     (loop for record = child then parent
1710     for parent = (output-record-parent record)
1711     when (eq parent nil) do (return nil)
1712     when (eq parent ancestor) do (return t)))
1713    
1714 adejneka 1.46 (defmethod erase-output-record (record (stream standard-output-recording-stream)
1715     &optional (errorp t))
1716     (letf (((stream-recording-p stream) nil))
1717     (let ((region (bounding-rectangle record)))
1718     (with-bounding-rectangle* (x1 y1 x2 y2) region
1719 adejneka 1.47 (if (output-record-ancestor-p (stream-output-history stream) record)
1720     (progn
1721     (delete-output-record record (output-record-parent record))
1722 adejneka 1.49 (with-output-recording-options (stream :record nil)
1723     (draw-rectangle* stream x1 y1 x2 y2 :ink +background-ink+))
1724 adejneka 1.47 (stream-replay stream region))
1725     (when errorp
1726     (error "~S is not contained in ~S." record stream)))))))
1727 adejneka 1.46
1728     (defun copy-textual-output-history (window stream &optional region record)
1729     ;; FIXME
1730     (declare (ignore window stream region record))
1731     (error "Not implemented."))
1732    
1733     ;;; 16.4.3. Text Output Recording
1734     (defmethod stream-text-output-record
1735     ((stream standard-output-recording-stream) text-style)
1736 mikemac 1.30 (declare (ignore text-style))
1737 adejneka 1.20 (let ((record (stream-current-text-output-record stream)))
1738 adejneka 1.47 (unless (and record (typep record 'standard-text-displayed-output-record))
1739     (multiple-value-bind (cx cy) (stream-cursor-position stream)
1740     (setf record (make-instance 'standard-text-displayed-output-record
1741     :x-position cx :y-position cy
1742 moore 1.57 :start-x cx :start-y cy
1743     :stream stream)
1744 adejneka 1.47 (stream-current-text-output-record stream) record)))
1745 adejneka 1.20 record))
1746    
1747 adejneka 1.46 (defmethod stream-close-text-output-record
1748     ((stream standard-output-recording-stream))
1749 adejneka 1.20 (let ((record (stream-current-text-output-record stream)))
1750     (when record
1751     (setf (stream-current-text-output-record stream) nil)
1752     #|record stream-current-cursor-position to (end-x record) - already done|#
1753     (stream-add-output-record stream record))))
1754    
1755 adejneka 1.46 (defmethod stream-add-character-output
1756     ((stream standard-output-recording-stream)
1757     character text-style width height baseline)
1758     (add-character-output-to-text-record
1759     (stream-text-output-record stream text-style)
1760     character text-style width height baseline))
1761 adejneka 1.20
1762 adejneka 1.22 (defmethod stream-add-string-output ((stream standard-output-recording-stream)
1763 adejneka 1.20 string start end text-style
1764     width height baseline)
1765 adejneka 1.46 (add-string-output-to-text-record (stream-text-output-record stream
1766     text-style)
1767 adejneka 1.20 string start end text-style
1768     width height baseline))
1769    
1770 adejneka 1.46 ;;; Text output catching methods
1771 adejneka 1.20 (defmacro without-local-recording (stream &body body)
1772 adejneka 1.22 `(letf (((slot-value ,stream 'local-record-p) nil))
1773 adejneka 1.47 ,@body))
1774 adejneka 1.22
1775 moore 1.67 (defmethod stream-write-output :around
1776 hefner1 1.69 ((stream standard-output-recording-stream) line
1777     &optional (start 0) end)
1778 adejneka 1.22 (when (and (stream-recording-p stream)
1779     (slot-value stream 'local-record-p))
1780     (let* ((medium (sheet-medium stream))
1781 moore 1.67 (text-style (medium-text-style medium))
1782     (height (text-style-height text-style medium))
1783     (ascent (text-style-ascent text-style medium)))
1784     (if (characterp line)
1785     (stream-add-character-output stream line text-style
1786     (stream-character-width
1787     stream line :text-style text-style)
1788     height
1789     ascent)
1790 hefner1 1.69 (stream-add-string-output stream line start end text-style
1791 moore 1.67 (stream-string-width stream line
1792 hefner1 1.69 :start start :end end
1793 moore 1.67 :text-style text-style)
1794 hefner1 1.69
1795 moore 1.67 height
1796     ascent))))
1797 adejneka 1.22 (when (stream-drawing-p stream)
1798     (without-local-recording stream
1799     (call-next-method))))
1800 cvs 1.5
1801 adejneka 1.22 #+nil
1802     (defmethod stream-write-char :around ((stream standard-output-recording-stream) char)
1803 adejneka 1.20 (when (and (stream-recording-p stream)
1804     (slot-value stream 'local-record-p))
1805     (if (or (eql char #\return)
1806 moore 1.57
1807 adejneka 1.20 (stream-close-text-output-record stream)
1808 cvs 1.8 (let* ((medium (sheet-medium stream))
1809 strandh 1.26 (text-style (medium-text-style medium)))
1810 adejneka 1.20 (stream-add-character-output stream char text-style
1811     (stream-character-width stream char :text-style text-style)
1812 strandh 1.26 (text-style-height text-style medium)
1813     (text-style-ascent text-style medium)))))
1814 adejneka 1.20 (without-local-recording stream
1815 moore 1.57 (call-next-method))))
1816 adejneka 1.20
1817 adejneka 1.21 #+nil
1818 adejneka 1.22 (defmethod stream-write-string :around ((stream standard-output-recording-stream) string
1819 adejneka 1.20 &optional (start 0) end)
1820 adejneka 1.21 ;; Problem: it is necessary to check for line wrapping. Now the
1821     ;; default method for STREAM-WRITE-STRING do char-by-char output,
1822     ;; therefore STREAM-WRITE-CHAR can do the right thing.
1823 adejneka 1.20 (when (and (stream-recording-p stream)
1824     (slot-value stream 'local-record-p))
1825     (let* ((medium (sheet-medium stream))
1826 strandh 1.26 (text-style (medium-text-style medium)))
1827 adejneka 1.20 (stream-add-string-output stream string start end text-style
1828     (stream-string-width stream string
1829     :start start :end end
1830     :text-style text-style)
1831 strandh 1.26 (text-style-height text-style medium)
1832     (text-style-ascent text-style medium))))
1833 adejneka 1.20 (without-local-recording stream
1834     (call-next-method)))
1835 adejneka 1.41
1836 adejneka 1.20
1837 adejneka 1.22 (defmethod stream-finish-output :after ((stream standard-output-recording-stream))
1838 adejneka 1.20 (stream-close-text-output-record stream))
1839    
1840 adejneka 1.22 (defmethod stream-force-output :after ((stream standard-output-recording-stream))
1841 adejneka 1.20 (stream-close-text-output-record stream))
1842    
1843 adejneka 1.22 (defmethod stream-terpri :after ((stream standard-output-recording-stream))
1844 adejneka 1.21 (stream-close-text-output-record stream))
1845    
1846 rouanet 1.23 (defmethod* (setf stream-cursor-position) :after (x y (stream standard-output-recording-stream))
1847 hefner1 1.66 (declare (ignore x y))
1848 moore 1.68 (stream-close-text-output-record stream))
1849 adejneka 1.20
1850 adejneka 1.22 ;(defmethod stream-set-cursor-position :after ((stream standard-output-recording-stream))
1851 adejneka 1.20 ; (stream-close-text-output-record stream))
1852 cvs 1.5
1853 adejneka 1.22 (defmethod stream-wrap-line :before ((stream standard-output-recording-stream))
1854 cvs 1.5 (when (stream-recording-p stream)
1855 adejneka 1.20 (setf (text-record-wrapped (stream-text-output-record stream nil)) ; FIXME!
1856     (stream-text-margin stream))))
1857 adejneka 1.46
1858     ;;; 16.4.4. Output Recording Utilities
1859    
1860     (defmethod invoke-with-output-recording-options
1861     ((stream output-recording-stream) continuation record draw)
1862     "Calls CONTINUATION on STREAM enabling or disabling recording and drawing
1863     according to the flags RECORD and DRAW."
1864     (letf (((stream-recording-p stream) record)
1865     ((stream-drawing-p stream) draw))
1866     (funcall continuation stream)))
1867    
1868     (defmethod invoke-with-new-output-record ((stream output-recording-stream)
1869     continuation record-type
1870     &rest initargs
1871 adejneka 1.50 &key
1872 adejneka 1.46 &allow-other-keys)
1873     (stream-close-text-output-record stream)
1874 adejneka 1.47 (let ((new-record (apply #'make-instance record-type initargs)))
1875 adejneka 1.46 (letf (((stream-current-output-record stream) new-record))
1876     ;; Should we switch on recording? -- APD
1877     (funcall continuation stream new-record)
1878     (finish-output stream))
1879     (stream-add-output-record stream new-record)
1880     new-record))
1881    
1882     (defmethod invoke-with-output-to-output-record
1883     ((stream output-recording-stream) continuation record-type
1884     &rest initargs
1885 adejneka 1.50 &key
1886 adejneka 1.46 &allow-other-keys)
1887     (stream-close-text-output-record stream)
1888 adejneka 1.47 (let ((new-record (apply #'make-instance record-type initargs)))
1889 adejneka 1.46 (with-output-recording-options (stream :record t :draw nil)
1890 adejneka 1.48 (letf (((stream-current-output-record stream) new-record)
1891     ((stream-cursor-position stream) (values 0 0)))
1892     (funcall continuation stream new-record)
1893     (finish-output stream)))
1894 adejneka 1.46 new-record))
1895    
1896     (defmethod make-design-from-output-record (record)
1897     ;; FIXME
1898     (declare (ignore record))
1899     (error "Not implemented."))
1900    
1901    
1902     ;;; Additional methods
1903     (defmethod scroll-vertical :around ((stream output-recording-stream) dy)
1904     (declare (ignore dy))
1905     (with-output-recording-options (stream :record nil)
1906     (call-next-method)))
1907    
1908     (defmethod scroll-horizontal :around ((stream output-recording-stream) dx)
1909     (declare (ignore dx))
1910     (with-output-recording-options (stream :record nil)
1911     (call-next-method)))
1912    
1913     (defmethod handle-repaint ((stream output-recording-stream) region)
1914     (stream-replay stream region))
1915    
1916 moore 1.64 (defmethod scroll-extent :around ((stream output-recording-stream) x y)
1917     (when (stream-drawing-p stream)
1918     (call-next-method)))
1919 gilbert 1.72
1920     ;;; ----------------------------------------------------------------------------
1921    
1922     (defmethod invoke-with-room-for-graphics (cont stream
1923     &key (first-quadrant t)
1924     height
1925     (move-cursor t)
1926     (record-type 'standard-sequence-output-record))
1927     ;; I am not sure what exactly :height should do.
1928     ;; --GB 2003-05-25
1929     (multiple-value-bind (cx cy)
1930     (stream-cursor-position stream)
1931     (let ((record
1932     (with-output-recording-options (stream :draw nil :record t)
1933     (with-new-output-record (stream record-type)
1934     (with-drawing-options
1935     (stream :transformation
1936     (if first-quadrant
1937     (make-scaling-transformation 1 -1)
1938     +identity-transformation+))
1939     (funcall cont stream))))))
1940     (cond ((null height)
1941     (setf (output-record-position record)
1942     (values cx cy)))
1943     (t
1944     (setf (output-record-position record)
1945     (values cx (- cy (- (bounding-rectangle-height record) height))))))
1946     (with-output-recording-options (stream :draw t :record nil)
1947     (replay-output-record record stream))
1948     (cond (move-cursor
1949     (setf (stream-cursor-position stream)
1950     (values (bounding-rectangle-max-x record)
1951     (bounding-rectangle-max-y record))))
1952     (t
1953     (setf (stream-cursor-position stream)
1954     (values cx cy)))))))
1955    

  ViewVC Help
Powered by ViewVC 1.1.5