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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.52 - (hide annotations)
Fri Jul 19 06:42:49 2002 UTC (11 years, 9 months ago) by adejneka
Branch: MAIN
Changes since 1.51: +51 -34 lines
Computation of size of standard polygon output records takes into
account MEDIUM-MITER-LIMIT.
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     ;;; - Computation of the bounding rectangle of lines ignores
50     ;;; LINE-STYLE-CAP-SHAPE.
51 adejneka 1.52 ;;;
52     ;;; - Computation of the bounding rectangle of polygons knows nothing
53     ;;; about :BEVEL.
54     ;;;
55     ;;; - Rounding of coordinates.
56     ;;;
57     ;;; - Document carefully the interface of
58     ;;; STANDARD-OUTPUT-RECORDING-STREAM.
59 adejneka 1.46
60 adejneka 1.47 ;;; Bug: (SETF OUTPUT-RECORD-POSITION) returns the record instead of
61     ;;; the position. It is useful for debugging, but it is wrong.
62    
63     ;;; Troubles
64    
65     ;;; DC
66     ;;;
67     ;;; Some GFs are defined to have "a default method on CLIM's standard
68     ;;; output record class". What does it mean? What is "CLIM's standard
69     ;;; output record class"? Is it OUTPUT-RECORD or BASIC-OUTPUT-RECORD?
70     ;;; Now they are defined on OUTPUT-RECORD.
71    
72     ;;; TDO
73     ;;;
74     ;;; Text output record must save ink and clipping region. But its
75     ;;; protocol does not give any way to do it! And a user can put in a
76     ;;; history a record of any class :(. Now we are using
77     ;;; *DRAWING-OPTIONS* to put the necessary information and make sure
78     ;;; that only instances of STANDARD-TEXT-OUTPUT-RECORD are used for
79     ;;; recording. -- APD, 2002-06-15.
80 adejneka 1.22
81 mikemac 1.1 (in-package :CLIM-INTERNALS)
82    
83 adejneka 1.46 (define-protocol-class output-record (bounding-rectangle)
84 moore 1.34 ())
85    
86 adejneka 1.46 (define-protocol-class displayed-output-record (output-record)
87 moore 1.34 ())
88 mikemac 1.1
89 adejneka 1.46 ;;; 16.2.1. The Basic Output Record Protocol
90 mikemac 1.30 #+:cmu(declaim (ftype (function (output-record) (values rational rational))
91     output-record-position))
92 adejneka 1.22 (defgeneric output-record-position (record)
93     (:documentation
94     "Returns the x and y position of RECORD. The position is the
95     position of the upper-left corner of its bounding rectangle. The
96     position is relative to the stream, where (0,0) is (initially) the
97     upper-left corner of the stream."))
98    
99 adejneka 1.49 (defgeneric* (setf output-record-position) (x y record)
100     (:documentation
101     "Changes the x and y position of the RECORD to be X and Y, and
102     updates the bounding rectangle to reflect the new position (and saved
103     cursor positions, if the output record stores it). If RECORD has any
104     children, all of the children (and their descendants as well) will be
105     moved by the same amount as RECORD was moved. The bounding rectangles
106     of all of RECORD's ancestors will also be updated to be large enough
107     to contain RECORD."))
108 adejneka 1.22
109 mikemac 1.30 #+:cmu(declaim (ftype (function (output-record) (values integer integer))
110     output-record-start-cursor-position))
111 adejneka 1.22 (defgeneric output-record-start-cursor-position (record)
112     (:documentation
113     "Returns the x and y starting cursor position of RECORD. The
114     positions are relative to the stream, where (0,0) is (initially) the
115     upper-left corner of the stream."))
116    
117 rouanet 1.23 (defgeneric* (setf output-record-start-cursor-position) (x y record))
118 adejneka 1.22
119 mikemac 1.30 #+:cmu(declaim (ftype (function (output-record) (values integer integer))
120     output-record-end-cursor-position))
121 adejneka 1.22 (defgeneric output-record-end-cursor-position (record)
122     (:documentation
123     "Returns the x and y ending cursor position of RECORD. The
124     positions are relative to the stream, where (0,0) is (initially) the
125     upper-left corner of the stream."))
126    
127 rouanet 1.23 (defgeneric* (setf output-record-end-cursor-position) (x y record))
128 adejneka 1.22
129     (defgeneric output-record-parent (record)
130     (:documentation
131 adejneka 1.46 "Returns the output record that is the parent of RECORD, or NIL if
132 adejneka 1.22 RECORD has no parent."))
133    
134 adejneka 1.47 (defgeneric (setf output-record-parent) (parent record)
135     (:documentation "Non-standard function."))
136    
137 adejneka 1.21 (defgeneric replay-output-record (record stream
138 adejneka 1.22 &optional region x-offset y-offset)
139     (:documentation "Displays the output captured by RECORD on the
140     STREAM, exactly as it was originally captured. The current user
141     transformation, line style, text style, ink and clipping region of
142     STREAM are all ignored. Instead, these are gotten from the output
143     record.
144    
145     Only those records that overlap REGION are displayed."))
146    
147 adejneka 1.21 (defgeneric output-record-hit-detection-rectangle* (record))
148 adejneka 1.22
149 adejneka 1.21 (defgeneric output-record-refined-position-test (record x y))
150 adejneka 1.22
151 adejneka 1.21 (defgeneric highlight-output-record (record stream state))
152 adejneka 1.22
153 adejneka 1.21 (defgeneric displayed-output-record-ink (displayed-output-record))
154    
155 adejneka 1.46 ;;; 16.2.2. Output Record "Database" Protocol
156 adejneka 1.22
157 adejneka 1.21 (defgeneric output-record-children (record))
158 adejneka 1.22
159 adejneka 1.21 (defgeneric add-output-record (child record))
160 adejneka 1.22
161 adejneka 1.46 (defgeneric delete-output-record (child record &optional errorp))
162 adejneka 1.22
163 adejneka 1.21 (defgeneric clear-output-record (record))
164 adejneka 1.22
165 adejneka 1.21 (defgeneric output-record-count (record))
166 adejneka 1.22
167 adejneka 1.21 (defgeneric map-over-output-records-containing-position
168 adejneka 1.46 (function record x y &optional x-offset y-offset &rest function-args)
169     (:documentation "Maps over all of the children of RECORD that
170     contain the point at (X,Y), calling FUNCTION on each one. FUNCTION is
171     a function of one or more arguments, the first argument being the
172     record containing the point. FUNCTION is also called with all of
173     FUNCTION-ARGS as APPLY arguments.
174    
175     If there are multiple records that contain the point,
176     MAP-OVER-OUTPUT-RECORDS-CONTAINING-POSITION hits the most recently
177     inserted record first and the least recently inserted record
178     last. Otherwise, the order in which the records are traversed is
179     unspecified."))
180 adejneka 1.22
181 adejneka 1.21 (defgeneric map-over-output-records-overlapping-region
182 adejneka 1.46 (function record region &optional x-offset y-offset &rest function-args)
183     (:documentation "Maps over all of the children of the RECORD that
184     overlap the REGION, calling FUNCTION on each one. FUNCTION is a
185     function of one or more arguments, the first argument being the record
186     overlapping the region. FUNCTION is also called with all of
187     FUNCTION-ARGS as APPLY arguments.
188    
189     If there are multiple records that overlap the region and that overlap
190     each other, MAP-OVER-OUTPUT-RECORDS-OVERLAPPING-REGION hits the least
191     recently inserted record first and the most recently inserted record
192     last. Otherwise, the order in which the records are traversed is
193     unspecified. "))
194 adejneka 1.21
195 moore 1.34 ;;; From the Franz CLIM user's guide but not in the spec... clearly necessary.
196 adejneka 1.46 ;;; What is its status? -- APD, 2002-06-14.
197 moore 1.34 (defgeneric map-over-output-records
198     (continuation record &optional x-offset y-offset &rest continuation-args))
199    
200 adejneka 1.46 ;;; 16.2.3. Output Record Change Notification Protocol
201 adejneka 1.22
202 adejneka 1.21 (defgeneric recompute-extent-for-new-child (record child))
203 adejneka 1.22
204 adejneka 1.21 (defgeneric recompute-extent-for-changed-child
205     (record child old-min-x old-min-y old-max-x old-max-y))
206 adejneka 1.22
207 adejneka 1.21 (defgeneric tree-recompute-extent (record))
208    
209 adejneka 1.46 ;;; 16.3. Types of Output Records
210     (define-protocol-class graphics-displayed-output-record (output-record)
211     ())
212 adejneka 1.22
213 adejneka 1.46 (define-protocol-class text-displayed-output-record (displayed-output-record)
214     ())
215    
216     ;;; 16.3.3. Text Displayed Output Record
217     (defgeneric add-character-output-to-text-record
218     (text-record character text-style width height baseline))
219    
220     (defgeneric add-string-output-to-text-record
221     (text-record string start end text-style width height baseline))
222    
223     (defgeneric text-displayed-output-record-string (text-record))
224    
225     ;;; 16.4. Output Recording Streams
226     (define-protocol-class output-recording-stream ()
227     ())
228    
229     ;;; 16.4.1. The Output Recording Stream Protocol
230     (defgeneric stream-recording-p (stream))
231    
232     (defgeneric (setf stream-recording-p) (recording-p stream))
233    
234     (defgeneric stream-drawing-p (stream))
235    
236     (defgeneric (setf stream-drawing-p) (drawing-p stream))
237    
238     (defgeneric stream-output-history (stream))
239 moore 1.34
240 adejneka 1.46 (defgeneric stream-current-output-record (stream))
241    
242     (defgeneric (setf stream-current-output-record) (record stream))
243    
244     (defgeneric stream-add-output-record (stream record))
245    
246     (defgeneric stream-replay (stream &optional region))
247    
248     (defgeneric erase-output-record (record stream &optional errorp))
249    
250     ;;; 16.4.3. Text Output Recording
251     (defgeneric stream-text-output-record (stream text-style))
252    
253     (defgeneric stream-close-text-output-record (stream))
254    
255     (defgeneric stream-add-character-output
256     (stream character text-style width height baseline))
257    
258     (defgeneric stream-add-string-output
259     (stream string start end text-style width height baseline))
260    
261     ;;; 16.4.4. Output Recording Utilities
262     (defgeneric invoke-with-output-recording-options
263     (stream continuation record draw))
264    
265     (defgeneric invoke-with-new-output-record (stream continuation record-type
266     &rest initargs
267 adejneka 1.50 &key
268 adejneka 1.46 &allow-other-keys))
269    
270     (defgeneric invoke-with-output-to-output-record
271     (stream continuation record-type
272     &rest initargs
273 adejneka 1.50 &key
274 adejneka 1.46 &allow-other-keys))
275    
276     (defgeneric make-design-from-output-record (record))
277    
278 adejneka 1.49 ;;; Macros
279     (defmacro with-output-recording-options ((stream
280     &key (record nil record-supplied-p)
281     (draw nil draw-supplied-p))
282     &body body)
283     (when (eq stream 't) (setq stream '*standard-output*))
284     (check-type stream symbol)
285     (with-gensyms (continuation)
286     `(flet ((,continuation (,stream) ,@body))
287     (declare (dynamic-extent #',continuation))
288     (invoke-with-output-recording-options
289     ,stream #',continuation
290     ,(if record-supplied-p record `(stream-recording-p ,stream))
291     ,(if draw-supplied-p draw `(stream-drawing-p ,stream))))))
292    
293     (defmacro with-new-output-record ((stream
294     &optional
295     (record-type ''standard-sequence-output-record)
296     (record nil record-supplied-p)
297     &rest initargs)
298     &body body)
299     "Creates a new output record of type RECORD-TYPE and then captures
300     the output of BODY into the new output record, and inserts the new
301     record into the current \"open\" output record assotiated with STREAM.
302     If RECORD is supplied, it is the name of a variable that will be
303     lexically bound to the new output record inside the body. INITARGS are
304     CLOS initargs that are passed to MAKE-INSTANCE when the new output
305     record is created.
306     It returns the created output record.
307     The STREAM argument is a symbol that is bound to an output
308     recording stream. If it is T, *STANDARD-OUTPUT* is used."
309     (when (eq stream 't) (setq stream '*standard-output*))
310     (check-type stream symbol)
311     (unless record-supplied-p (setq record (gensym)))
312     `(invoke-with-new-output-record ,stream
313     #'(lambda (,stream ,record)
314     (declare (ignorable ,stream ,record))
315     ,@body)
316     ,record-type
317     ,@initargs))
318    
319     (defmacro with-output-to-output-record
320     ((stream
321     &optional (record-type ''standard-sequence-output-record)
322     (record nil record-supplied-p)
323     &rest initargs)
324     &body body)
325     "Creates a new output record of type RECORD-TYPE and then captures
326     the output of BODY into the new output record. The cursor position of
327     STREAM is initially bound to (0,0)
328     If RECORD is supplied, it is the name of a variable that will be
329     lexically bound to the new output record inside the body. INITARGS are
330     CLOS initargs that are passed to MAKE-INSTANCE when the new output
331     record is created.
332     It returns the created output record.
333     The STREAM argument is a symbol that is bound to an output
334     recording stream. If it is T, *STANDARD-OUTPUT* is used."
335     (when (eq stream 't) (setq stream '*standard-output*))
336     (check-type stream symbol)
337     (unless record-supplied-p (setq record (gensym "RECORD")))
338     `(invoke-with-output-to-output-record
339     ,stream
340     #'(lambda (,stream ,record)
341     (declare (ignorable ,stream ,record))
342     ,@body)
343     ,record-type
344     ,@initargs))
345    
346 adejneka 1.46
347     ;;;; Implementation
348    
349     (defclass basic-output-record (standard-bounding-rectangle output-record)
350 adejneka 1.47 ((parent :initarg :parent ; XXX
351 adejneka 1.46 :initform nil
352 adejneka 1.47 :accessor output-record-parent)) ; XXX
353 adejneka 1.46 (:documentation "Implementation class for the Basic Output Record Protocol."))
354    
355     (defmethod initialize-instance :after ((record basic-output-record)
356 adejneka 1.50 &rest args
357     &key (x-position 0) (y-position 0))
358 adejneka 1.46 (declare (ignore args))
359     (with-slots (x1 y1 x2 y2) record
360     (setq x1 x-position
361     y1 y-position
362     x2 x-position
363     y2 y-position)))
364    
365     (defclass compound-output-record (basic-output-record)
366     ((x :initarg :x-position
367     :initform 0
368     :documentation "X-position of the empty record.")
369     (y :initarg :y-position
370     :initform 0
371     :documentation "Y-position of the empty record.")
372     (in-moving-p :initform nil
373     :documentation "Is set while changing the position."))
374     (:documentation "Implementation class for output records with children."))
375    
376     ;;; 16.2.1. The Basic Output Record Protocol
377     (defmethod output-record-position ((record basic-output-record))
378     (bounding-rectangle-position record))
379 mikemac 1.1
380 adejneka 1.46 (defmethod* (setf output-record-position) (nx ny (record basic-output-record))
381     (with-slots (x1 y1 x2 y2) record
382     (let ((dx (- nx x1))
383     (dy (- ny y1)))
384     (setf x1 nx y1 ny
385 adejneka 1.47 x2 (+ x2 dx) y2 (+ y2 dy))))
386     record)
387 rouanet 1.11
388 moore 1.34 (defmethod* (setf output-record-position) :around
389     (nx ny (record basic-output-record))
390 rouanet 1.11 (declare (ignore nx ny))
391 adejneka 1.46 (with-bounding-rectangle* (min-x min-y max-x max-y) record
392     (call-next-method)
393     (let ((parent (output-record-parent record)))
394     (when parent
395     (recompute-extent-for-changed-child parent record
396 adejneka 1.47 min-x min-y max-x max-y))))
397     record)
398 moore 1.34
399 adejneka 1.46 (defmethod* (setf output-record-position) :before
400     (nx ny (record compound-output-record))
401     (with-slots (x1 y1 in-moving-p) record
402     (letf ((in-moving-p t))
403     (let ((dx (- nx x1))
404     (dy (- ny y1)))
405     (map-over-output-records
406     (lambda (child)
407     (multiple-value-bind (x y) (output-record-position child)
408     (setf (output-record-position child)
409     (values (+ x dx) (+ y dy)))))
410     record)))))
411 rouanet 1.11
412 moore 1.34 (defmethod output-record-start-cursor-position ((record basic-output-record))
413 mikemac 1.1 (values nil nil))
414    
415 moore 1.34 (defmethod* (setf output-record-start-cursor-position)
416     (x y (record basic-output-record))
417 mikemac 1.1 (declare (ignore x y))
418     nil)
419    
420 moore 1.34 (defmethod output-record-end-cursor-position ((record basic-output-record))
421 mikemac 1.1 (values nil nil))
422    
423 moore 1.34 (defmethod* (setf output-record-end-cursor-position)
424     (x y (record basic-output-record))
425 mikemac 1.1 (declare (ignore x y))
426     nil)
427    
428 adejneka 1.24 (defun replay (record stream &optional region)
429 adejneka 1.21 (stream-close-text-output-record stream)
430 rouanet 1.11 (when (stream-drawing-p stream)
431 adejneka 1.22 (with-cursor-off stream
432 adejneka 1.48 (letf (((stream-cursor-position stream) (values 0 0))
433     ((stream-recording-p stream) nil))
434     (replay-output-record record stream region)))))
435 mikemac 1.1
436 adejneka 1.46 (defmethod replay-output-record ((record compound-output-record) stream
437 rouanet 1.18 &optional region (x-offset 0) (y-offset 0))
438 rouanet 1.11 (when (null region)
439     (setq region +everywhere+))
440 moore 1.34 (map-over-output-records-overlapping-region
441 rouanet 1.11 #'replay-output-record record region x-offset y-offset
442     stream region x-offset y-offset))
443 mikemac 1.1
444 adejneka 1.46 (defmethod output-record-hit-detection-rectangle* ((record output-record))
445     ;; XXX DC
446 mikemac 1.1 (bounding-rectangle* record))
447    
448 moore 1.39 (defmethod output-record-refined-position-test ((record basic-output-record)
449     x y)
450 rouanet 1.13 (declare (ignore x y))
451     t)
452 mikemac 1.1
453 moore 1.34 ;;; XXX Should this only be defined on recording streams?
454 adejneka 1.46 (defmethod highlight-output-record ((record output-record)
455 moore 1.34 stream state)
456 adejneka 1.46 ;; XXX DC
457     ;; XXX Disable recording?
458     (letf (((medium-transformation stream) +identity-transformation+))
459     (multiple-value-bind (x1 y1 x2 y2)
460     (output-record-hit-detection-rectangle* record)
461     (ecase state
462     (:highlight
463     (draw-rectangle* (sheet-medium stream) x1 y1 x2 y2
464 adejneka 1.52 :filled nil :ink +foreground-ink+)) ; XXX +FLIPPING-INK+?
465 adejneka 1.46 (:unhighlight
466     (draw-rectangle* (sheet-medium stream) x1 y1 x2 y2
467 adejneka 1.52 :filled nil :ink +background-ink+)))))) ; XXX +FLIPPING-INK+?
468 rouanet 1.11
469 adejneka 1.46 ;;; 16.2.2. The Output Record "Database" Protocol
470     (defmethod output-record-children ((record basic-output-record))
471     nil)
472 mikemac 1.1
473 adejneka 1.46 (defmethod add-output-record (child (record basic-output-record))
474     (declare (ignore child))
475     (error "Cannot add a child to ~S." record))
476 rouanet 1.11
477 adejneka 1.47 (defmethod add-output-record :before (child (record compound-output-record))
478     (let ((parent (output-record-parent child)))
479     (when parent
480     (restart-case
481     (error "~S already has a parent ~S." child parent)
482     (delete ()
483     :report "Delete from the old parent."
484     (delete-output-record child parent))))))
485    
486 adejneka 1.46 (defmethod add-output-record :after (child (record compound-output-record))
487 rouanet 1.11 (recompute-extent-for-new-child record child))
488    
489 adejneka 1.46 (defmethod delete-output-record (child (record basic-output-record)
490     &optional (errorp t))
491     (declare (ignore child))
492     (when errorp (error "Cannot delete a child from ~S." record)))
493 mikemac 1.1
494 adejneka 1.46 (defmethod delete-output-record :after (child (record compound-output-record)
495     &optional (errorp t))
496 rouanet 1.11 (declare (ignore errorp))
497     (with-bounding-rectangle* (x1 y1 x2 y2) child
498     (recompute-extent-for-changed-child record child x1 y1 x2 y2)))
499    
500 adejneka 1.46 (defmethod clear-output-record ((record basic-output-record))
501     (error "Cannot clear ~S." record))
502    
503     (defmethod clear-output-record :after ((record compound-output-record))
504     (with-slots (x y x1 y1 x2 y2) record
505     (setf x1 x y1 y
506     x2 x y2 y)))
507    
508     (defmethod output-record-count ((record basic-output-record))
509     0)
510 mikemac 1.1
511 adejneka 1.46 (defmethod map-over-output-records
512     (function (record basic-output-record)
513     &optional (x-offset 0) (y-offset 0)
514     &rest function-args)
515     (declare (ignore function x-offset y-offset function-args))
516     nil)
517 mikemac 1.1
518 adejneka 1.46 ;;; This needs to work in "most recently added last" order. Is this
519     ;;; implementation right? -- APD, 2002-06-13
520     #+nil
521 moore 1.39 (defmethod map-over-output-records
522 adejneka 1.46 (function (record compound-output-record)
523 moore 1.35 &optional (x-offset 0) (y-offset 0)
524     &rest function-args)
525     (declare (ignore x-offset y-offset))
526 adejneka 1.46 (map nil (lambda (child) (apply function child function-args))
527     (output-record-children record)))
528    
529     (defmethod map-over-output-records-containing-position
530     (function (record basic-output-record) x y
531     &optional (x-offset 0) (y-offset 0)
532     &rest function-args)
533     (declare (ignore function x y x-offset y-offset function-args))
534     nil)
535 moore 1.35
536 adejneka 1.46 ;;; This needs to work in "most recently added first" order. Is this
537     ;;; implementation right? -- APD, 2002-06-13
538     #+nil
539 moore 1.35 (defmethod map-over-output-records-containing-position
540 adejneka 1.46 (function (record compound-output-record) x y
541 moore 1.35 &optional (x-offset 0) (y-offset 0)
542     &rest function-args)
543 moore 1.36 (declare (ignore x-offset y-offset))
544 adejneka 1.46 (map nil
545     (lambda (child)
546     (when (and (multiple-value-bind (min-x min-y max-x max-y)
547 moore 1.39 (output-record-hit-detection-rectangle* child)
548     (and (<= min-x x max-x) (<= min-y y max-y)))
549     (output-record-refined-position-test child x y))
550 adejneka 1.46 (apply function child function-args)))
551     (output-record-children record)))
552    
553     (defmethod map-over-output-records-overlapping-region
554     (function (record basic-output-record) region
555     &optional (x-offset 0) (y-offset 0)
556     &rest function-args)
557     (declare (ignore function region x-offset y-offset function-args))
558     nil)
559 mikemac 1.1
560 adejneka 1.46 ;;; This needs to work in "most recently added last" order. Is this
561     ;;; implementation right? -- APD, 2002-06-13
562     #+nil
563 moore 1.35 (defmethod map-over-output-records-overlapping-region
564 adejneka 1.46 (function (record compound-output-record) region
565 moore 1.35 &optional (x-offset 0) (y-offset 0)
566     &rest function-args)
567     (declare (ignore x-offset y-offset))
568 adejneka 1.46 (map nil
569     (lambda (child) (when (region-intersects-region-p region child)
570     (apply function child function-args)))
571     (output-record-children record)))
572 mikemac 1.1
573 adejneka 1.46 ;;; 16.2.3. Output Record Change Notification Protocol
574 moore 1.39 (defmethod recompute-extent-for-new-child
575 adejneka 1.46 ((record compound-output-record) child)
576 rouanet 1.11 (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2) record
577 adejneka 1.46 (with-slots (parent x1 y1 x2 y2) record
578     (if (= 1 (length (output-record-children record)))
579 moore 1.34 (setf (values x1 y1 x2 y2) (bounding-rectangle* child))
580     (with-bounding-rectangle* (x1-child y1-child x2-child y2-child) child
581     (minf x1 x1-child)
582     (minf y1 y1-child)
583     (maxf x2 x2-child)
584     (maxf y2 y2-child)))
585 rouanet 1.11 (when parent
586 moore 1.34 (recompute-extent-for-changed-child parent record
587 adejneka 1.47 old-x1 old-y1 old-x2 old-y2))))
588     record)
589 mikemac 1.1
590 adejneka 1.46 (defmethod %tree-recompute-extent* ((record compound-output-record))
591     ;; Internal helper function
592 moore 1.34 (let ((new-x1 0)
593     (new-y1 0)
594     (new-x2 0)
595     (new-y2 0)
596     (first-time t))
597     (map-over-output-records
598 adejneka 1.46 (lambda (child)
599     (if first-time
600     (progn
601     (multiple-value-setq (new-x1 new-y1 new-x2 new-y2)
602     (bounding-rectangle* child))
603     (setq first-time nil))
604     (with-bounding-rectangle* (cx1 cy1 cx2 cy2) child
605     (minf new-x1 cx1)
606     (minf new-y1 cy1)
607     (maxf new-x2 cx2)
608     (maxf new-y2 cy2))))
609 moore 1.34 record)
610     (if first-time
611 adejneka 1.46 (with-slots (x y) record
612     (values x y x y))
613 moore 1.34 (values new-x1 new-y1 new-x2 new-y2))))
614    
615     (defmethod recompute-extent-for-changed-child
616 adejneka 1.46 ((record compound-output-record) changed-child
617 moore 1.34 old-min-x old-min-y old-max-x old-max-y)
618     ;; If the child's old and new bbox lies entirely within the record's bbox
619     ;; then no change need be made to the record's bbox. Otherwise, if some part
620     ;; of the child's bbox was on the record's bbox and is now inside, examine
621     ;; all the children to determine the correct new bbox.
622     (with-slots (x1 y1 x2 y2) record
623     (with-bounding-rectangle* (child-x1 child-y1 child-x2 child-y2)
624     changed-child
625 adejneka 1.46 (unless (and (> x1 old-min-x) (> x1 child-x1)
626     (> y1 old-min-y) (> y1 child-y1)
627     (< x2 old-max-x) (< x2 child-x2)
628     (< y2 old-max-y) (< y2 child-y2))
629 moore 1.34 ;; Don't know if changed-child has been deleted or what, so go through
630     ;; all the children and construct the updated bbox.
631 adejneka 1.47 (setf (values x1 y1 x2 y2) (%tree-recompute-extent* record)))))
632     record)
633 moore 1.34
634 adejneka 1.46 (defmethod recompute-extent-for-changed-child :around
635     ((record compound-output-record) child
636     old-min-x old-min-y old-max-x old-max-y)
637     (declare (ignore child old-min-x old-min-y old-max-x old-max-y))
638     (unless (slot-value record 'in-moving-p)
639 adejneka 1.47 (let ((old-rectangle (multiple-value-call #'make-bounding-rectangle
640     (bounding-rectangle* record))))
641 adejneka 1.46 (call-next-method)
642     (with-slots (parent x1 y1 x2 y2) record
643     (when (and parent (not (region-equal old-rectangle record)))
644 adejneka 1.47 (multiple-value-call #'recompute-extent-for-changed-child
645     (values parent record)
646     (bounding-rectangle* old-rectangle))))))
647     record)
648 adejneka 1.46
649     (defmethod tree-recompute-extent ((record compound-output-record))
650 moore 1.34 (with-slots (x1 y1 x2 y2) record
651 adejneka 1.47 (setf (values x1 y1 x2 y2) (%tree-recompute-extent* record)))
652     record)
653 mikemac 1.1
654 adejneka 1.46 (defmethod tree-recompute-extent :around ((record compound-output-record))
655 adejneka 1.47 (let ((old-rectangle (multiple-value-call #'make-bounding-rectangle
656     (bounding-rectangle* record))))
657 adejneka 1.22 (call-next-method)
658     (with-slots (parent x1 y1 x2 y2) record
659 adejneka 1.41 (when (and parent (not (region-equal old-rectangle record)))
660 adejneka 1.47 (recompute-extent-for-changed-child parent record x1 y1 x2 y2))))
661     record)
662 mikemac 1.1
663 adejneka 1.46 ;;; 16.3.1. Standard output record classes
664 mikemac 1.1
665 adejneka 1.46 (defclass standard-sequence-output-record (compound-output-record)
666     ((children :initform (make-array 8 :adjustable t :fill-pointer 0)
667     :reader output-record-children)))
668 moore 1.34
669 adejneka 1.46 (defmethod add-output-record (child (record standard-sequence-output-record))
670 adejneka 1.47 (vector-push-extend child (output-record-children record))
671     (setf (output-record-parent child) record))
672 mikemac 1.1
673 adejneka 1.46 (defmethod delete-output-record (child (record standard-sequence-output-record)
674     &optional (errorp t))
675     (with-slots (children) record
676     (let ((pos (position child children :test #'eq)))
677     (if (null pos)
678     (when errorp
679     (error "~S is not a child of ~S" child record))
680     (progn
681     (setq children (replace children children
682     :start1 pos
683     :start2 (1+ pos)))
684 adejneka 1.47 (decf (fill-pointer children))
685     (setf (output-record-parent child) nil))))))
686 mikemac 1.1
687 adejneka 1.46 (defmethod clear-output-record ((record standard-sequence-output-record))
688 adejneka 1.47 (let ((children (output-record-children record)))
689     (map 'nil (lambda (child) (setf (output-record-parent child) nil))
690     children)
691 adejneka 1.46 (fill children nil)
692     (setf (fill-pointer children) 0)))
693 rouanet 1.11
694 adejneka 1.46 (defmethod output-record-count ((record standard-sequence-output-record))
695     (length (output-record-children record)))
696 rouanet 1.11
697 adejneka 1.46 (defmethod map-over-output-records
698     (function (record standard-sequence-output-record)
699     &optional (x-offset 0) (y-offset 0)
700     &rest function-args)
701     "Applies FUNCTION to all children in the order they were added."
702     (declare (ignore x-offset y-offset))
703     (loop with children = (output-record-children record)
704     for child across children
705     do (apply function child function-args)))
706 mikemac 1.1
707 adejneka 1.46 (defmethod map-over-output-records-containing-position
708     (function (record standard-sequence-output-record) x y
709     &optional (x-offset 0) (y-offset 0)
710     &rest function-args)
711     "Applies FUNCTION to children, containing (X,Y), in the reversed
712     order they were added."
713     (declare (ignore x-offset y-offset))
714     (loop with children = (output-record-children record)
715     for i from (1- (length children)) downto 0
716     for child = (aref children i)
717     when (and (multiple-value-bind (min-x min-y max-x max-y)
718     (output-record-hit-detection-rectangle* child)
719     (and (<= min-x x max-x) (<= min-y y max-y)))
720     (output-record-refined-position-test child x y))
721     do (apply function child function-args)))
722 cvs 1.7
723 adejneka 1.46 (defmethod map-over-output-records-overlapping-region
724     (function (record standard-sequence-output-record) region
725     &optional (x-offset 0) (y-offset 0)
726     &rest function-args)
727     "Applies FUNCTION to children, overlapping REGION, in the order they
728     were added."
729     (declare (ignore x-offset y-offset))
730     (loop with children = (output-record-children record)
731     for child across children
732     when (region-intersects-region-p region child)
733     do (apply function child function-args)))
734 rouanet 1.11
735 adejneka 1.46 ;;; XXX bogus for now.
736     (defclass standard-tree-output-record (standard-sequence-output-record)
737     (
738     ))
739 mikemac 1.1
740 adejneka 1.46 ;;; 16.3.2. Graphics Displayed Output Records
741     (defclass standard-displayed-output-record (basic-output-record
742     displayed-output-record)
743     ((ink :initarg :ink :reader displayed-output-record-ink)
744     (initial-x1 :initarg :initial-x1)
745     (initial-y1 :initarg :initial-y1))
746     (:documentation "Implementation class for DISPLAYED-OUTPUT-RECORD."))
747 mikemac 1.1
748 adejneka 1.46 (defclass standard-graphics-displayed-output-record
749     (standard-displayed-output-record graphics-displayed-output-record)
750     ((clip :initarg :clipping-region
751     :documentation "Clipping region in user coordinates.")
752     (transform :initarg :transformation)
753     (line-style :initarg :line-style)
754     (text-style :initarg :text-style)))
755 mikemac 1.1
756     (defmacro def-grecording (name (&rest args) &body body)
757     (let ((method-name (intern (format nil "MEDIUM-~A*" name)))
758     (class-name (intern (format nil "~A-OUTPUT-RECORD" name)))
759 adejneka 1.41 (medium (gensym "MEDIUM"))
760 adejneka 1.46 (class-vars `((stream :initarg :stream)
761     ,@(loop for arg in args
762     collect `(,arg
763     :initarg ,(intern (symbol-name arg)
764     :keyword)))))
765     (arg-list (loop for arg in args
766     nconc `(,(intern (symbol-name arg) :keyword) ,arg))))
767 cvs 1.10 `(progn
768 adejneka 1.46 (defclass ,class-name (standard-graphics-displayed-output-record)
769     ,class-vars)
770 mikemac 1.1 (defmethod initialize-instance :after ((graphic ,class-name) &rest args)
771     (declare (ignore args))
772 adejneka 1.46 (with-slots (x1 y1 x2 y2 initial-x1 initial-y1
773 adejneka 1.14 stream ink clipping-region transform
774 mikemac 1.1 line-style text-style
775     ,@args) graphic
776 adejneka 1.52 (let* ((medium (sheet-medium stream))
777     (border (/ (line-style-effective-thickness
778     line-style medium)
779 adejneka 1.44 2)))
780 adejneka 1.52 (declare (ignorable border))
781 adejneka 1.44 (multiple-value-setq (x1 y1 x2 y2) (progn ,@body)))
782 adejneka 1.46 (setf initial-x1 x1
783 rouanet 1.18 initial-y1 y1)))
784 rouanet 1.11 (defmethod ,method-name :around ((stream output-recording-stream) ,@args)
785 adejneka 1.47 ;; XXX STANDARD-OUTPUT-RECORDING-STREAM ^?
786 mikemac 1.1 (with-sheet-medium (medium stream)
787 cvs 1.5 (when (stream-recording-p stream)
788     (let ((record (make-instance ',class-name
789     :stream stream
790     :ink (medium-ink medium)
791     :clipping-region (medium-clipping-region medium)
792     :transformation (medium-transformation medium)
793     :line-style (medium-line-style medium)
794     :text-style (medium-text-style medium)
795 adejneka 1.46 ,@arg-list)))
796 rouanet 1.11 (stream-add-output-record stream record)))
797 cvs 1.5 (when (stream-drawing-p stream)
798     (call-next-method))))
799 mikemac 1.1 (defmethod replay-output-record ((record ,class-name) stream
800 rouanet 1.18 &optional (region +everywhere+)
801     (x-offset 0) (y-offset 0))
802 adejneka 1.46 (declare (ignore x-offset y-offset))
803     (with-slots (x1 y1 initial-x1 initial-y1
804 rouanet 1.18 ink clip transform line-style text-style ,@args) record
805     (let ((transformation (compose-translation-with-transformation
806     transform
807 adejneka 1.46 (- x1 initial-x1)
808     (- y1 initial-y1)))
809 adejneka 1.41 (,medium (sheet-medium stream))
810     ;; is sheet a sheet-with-medium-mixin? --GB
811     )
812     (letf (((medium-ink ,medium) ink)
813     ((medium-transformation ,medium) transformation)
814     ((medium-clipping-region ,medium)
815     (region-intersection clip
816     (untransform-region transformation
817     region)))
818     ((medium-line-style ,medium) line-style)
819     ((medium-text-style ,medium) text-style))
820     (,method-name ,medium ,@args))))))))
821 mikemac 1.1
822 rouanet 1.11 (def-grecording draw-point (point-x point-y)
823 adejneka 1.14 (with-transformed-position (transform point-x point-y)
824 adejneka 1.44 (values (- point-x border)
825     (- point-y border)
826     (+ point-x border)
827     (+ point-y border))))
828 mikemac 1.1
829     (def-grecording draw-points (coord-seq)
830 adejneka 1.14 (with-transformed-positions (transform coord-seq)
831     (loop for (x y) on coord-seq by #'cddr
832     minimize x into min-x
833     minimize y into min-y
834     maximize x into max-x
835     maximize y into max-y
836 adejneka 1.44 finally (return (values (- min-x border)
837     (- min-y border)
838     (+ max-x border)
839     (+ max-y border))))))
840 mikemac 1.1
841 rouanet 1.11 (def-grecording draw-line (point-x1 point-y1 point-x2 point-y2)
842 adejneka 1.14 (with-transformed-position (transform point-x1 point-y1)
843     (with-transformed-position (transform point-x2 point-y2)
844 adejneka 1.44 (values (- (min point-x1 point-x2) border)
845     (- (min point-y1 point-y2) border)
846     (+ (max point-x1 point-x2) border)
847     (+ (max point-y1 point-y2) border)))))
848 mikemac 1.1
849     (def-grecording draw-lines (coord-seq)
850 adejneka 1.14 (with-transformed-positions (transform coord-seq)
851     (loop for (x y) on coord-seq by #'cddr
852     minimize x into min-x
853     minimize y into min-y
854     maximize x into max-x
855     maximize y into max-y
856 adejneka 1.44 finally (return (values (- min-x border)
857     (- min-y border)
858     (+ max-x border)
859     (+ max-y border))))))
860 mikemac 1.1
861 adejneka 1.52 (defun polygon-record-bounding-rectangle
862     (coord-seq transform closed filled line-style border miter-limit)
863 adejneka 1.14 (with-transformed-positions (transform coord-seq)
864 adejneka 1.51 (if (or filled
865     (not (eq (line-style-joint-shape line-style) :miter)))
866 adejneka 1.52 ;; XXX The following is for :ROUND. What about :BEVEL and :NONE?
867 adejneka 1.51 (loop for (x y) on coord-seq by #'cddr
868 adejneka 1.14 minimize x into min-x
869     minimize y into min-y
870     maximize x into max-x
871     maximize y into max-y
872 adejneka 1.44 finally (return (if filled
873     (values min-x min-y max-x max-y)
874     (values (- min-x border)
875     (- min-y border)
876     (+ max-x border)
877 adejneka 1.51 (+ max-y border)))))
878     (flet ((normalize (dx dy &optional unit)
879     (let ((norm (sqrt (+ (* dx dx) (* dy dy)))))
880     (if unit
881     (let ((scale (/ unit norm)))
882     (values (* dx scale) (* dy scale)))
883     (values (/ dx norm) (/ dy norm))))))
884     (let* ((x1 (first coord-seq))
885     (y1 (second coord-seq))
886     (min-x (- x1 border)) (min-y (- y1 border))
887     (max-x (+ x1 border)) (max-y (+ y1 border)))
888 adejneka 1.52 ;; FIXME: Remove zero-length segments
889     (loop with sin-limit = (sin (* 0.5 miter-limit))
890     for (xp yp x y xn yn) on (if closed
891     `(,@(last coord-seq 2)
892     ,@coord-seq
893     ,(first coord-seq) ,(second coord-seq))
894     coord-seq)
895     by #'cddr
896 adejneka 1.51 unless yn do (minf min-x (- x border)) (minf min-y (- y border))
897     (maxf max-x (+ x border)) (maxf max-y (+ y border))
898     (return)
899     do (multiple-value-bind (nx1 ny1) (normalize (- x xp) (- y yp))
900     (multiple-value-bind (nx2 ny2) (normalize (- x xn) (- y yn))
901 adejneka 1.52 (let* ((cos-a (+ (* nx1 nx2) (* ny1 ny2)))
902     (sin-a/2 (sqrt (* 0.5 (- 1.0 cos-a)))))
903     (if (< sin-a/2 sin-limit)
904     (progn ; FIXME! This is for :ROUND, not for :BEVEL.
905     (minf min-x (- x border)) (minf min-y (- y border))
906     (maxf max-x (+ x border)) (maxf max-y (+ y border)))
907     (let ((length (/ border sin-a/2)))
908     (multiple-value-bind (dx dy)
909     (normalize (+ nx1 nx2) (+ ny1 ny2) length)
910     (let ((adx (abs dx)) (ady (abs dy)))
911     (minf min-x (- x adx)) (minf min-y (- y ady))
912     (maxf max-x (+ x adx)) (maxf max-y (+ y ady))))))))))
913 adejneka 1.51 (values min-x min-y max-x max-y))))))
914 mikemac 1.1
915 adejneka 1.52 (def-grecording draw-polygon (coord-seq closed filled)
916     (polygon-record-bounding-rectangle
917     coord-seq transform closed filled line-style border
918     (medium-miter-limit medium)))
919    
920 mikemac 1.1 (def-grecording draw-rectangle (left top right bottom filled)
921 adejneka 1.52 (polygon-record-bounding-rectangle
922     (list left top left bottom right bottom right top)
923     transform t filled line-style border
924     (medium-miter-limit medium)))
925 mikemac 1.1
926     (def-grecording draw-ellipse (center-x center-y
927     radius-1-dx radius-1-dy radius-2-dx radius-2-dy
928     start-angle end-angle filled)
929 adejneka 1.44 (multiple-value-bind (min-x min-y max-x max-y)
930     (bounding-rectangle*
931     (transform-region transform
932     (make-ellipse* center-x center-y
933     radius-1-dx radius-1-dy
934     radius-2-dx radius-2-dy
935     :start-angle start-angle
936     :end-angle end-angle)))
937     (if filled
938     (values min-x min-y max-x max-y)
939     (values (- min-x border)
940     (- min-y border)
941     (+ max-x border)
942     (+ max-y border)))))
943 rouanet 1.11
944     (def-grecording draw-text (string point-x point-y start end
945     align-x align-y toward-x toward-y transform-glyphs)
946 adejneka 1.44 ;; FIXME!!! Text direction.
947 adejneka 1.43 ;; Multiple lines?
948 rouanet 1.11 (let* ((width (stream-string-width stream string
949     :start start :end end
950     :text-style text-style))
951 strandh 1.26 (ascent (text-style-ascent text-style (sheet-medium stream)))
952     (descent (text-style-descent text-style (sheet-medium stream)))
953 rouanet 1.11 (height (+ ascent descent))
954     left top right bottom)
955     (ecase align-x
956     (:left (setq left point-x
957     right (+ point-x width)))
958     (:right (setq left (- point-x width)
959     right point-x))
960     (:center (setq left (- point-x (round width 2))
961     right (+ point-x (round width 2)))))
962     (ecase align-y
963 adejneka 1.43 (:baseline (setq top (- point-y ascent)
964 rouanet 1.11 bottom (+ point-y descent)))
965     (:top (setq top point-y
966     bottom (+ point-y height)))
967     (:bottom (setq top (- point-y height)
968     bottom point-y))
969     (:center (setq top (- point-y (floor height 2))
970     bottom (+ point-y (ceiling height 2)))))
971     (values left top right bottom)))
972 mikemac 1.1
973 adejneka 1.46 ;;; 16.3.3. Text Displayed Output Record
974 adejneka 1.47 (defvar *drawing-options* (list +foreground-ink+ +everywhere+)
975     "The ink and the clipping region of the current stream.") ; XXX TDO
976    
977     (defclass styled-string ()
978     ((start-x :initarg :start-x)
979     (text-style :initarg :text-style)
980     (ink :initarg :ink)
981     (clipping-region :initarg :clipping-region)
982     (string :initarg :string :reader styled-string-string)))
983 moore 1.34
984 adejneka 1.46 (defclass standard-text-displayed-output-record
985     (text-displayed-output-record standard-displayed-output-record)
986 adejneka 1.47 ((initial-x1 :initarg :start-x)
987     (initial-y1 :initarg :start-y)
988     (strings :initform nil)
989 mikemac 1.1 (baseline :initform 0)
990 adejneka 1.22 (width :initform 0)
991 mikemac 1.1 (max-height :initform 0)
992 cvs 1.6 (start-x :initarg :start-x)
993     (start-y :initarg :start-y)
994 adejneka 1.47 (end-x :initarg :start-x)
995     (end-y :initarg :start-y)
996 cvs 1.8 (wrapped :initform nil
997 adejneka 1.21 :accessor text-record-wrapped)))
998 mikemac 1.1
999 adejneka 1.46 (defmethod print-object ((self standard-text-displayed-output-record) stream)
1000 cvs 1.8 (print-unreadable-object (self stream :type t :identity t)
1001 adejneka 1.47 (with-slots (start-x start-y strings) self
1002     (format stream "~D,~D ~S"
1003     start-x start-y
1004     (mapcar #'styled-string-string strings)))))
1005 mikemac 1.1
1006 moore 1.34 (defmethod* (setf output-record-position) :before
1007 adejneka 1.46 (nx ny (record standard-text-displayed-output-record))
1008     (with-slots (x1 y1 start-x start-y end-x end-y) record
1009     (let ((dx (- nx x1))
1010     (dy (- ny y1)))
1011 rouanet 1.23 (incf start-x dx)
1012     (incf start-y dy)
1013     (incf end-x dx)
1014     (incf end-y dy))))
1015 cvs 1.9
1016 adejneka 1.46 (defmethod replay-output-record ((record standard-text-displayed-output-record)
1017 moore 1.34 stream
1018 adejneka 1.21 &optional region (x-offset 0) (y-offset 0))
1019 adejneka 1.46 (declare (ignore region x-offset y-offset))
1020 adejneka 1.47 (with-slots (strings baseline max-height start-y wrapped
1021 adejneka 1.46 x1 y1 initial-x1 initial-y1) record
1022 adejneka 1.47 (with-sheet-medium (medium stream) ;is sheet a sheet-with-medium-mixin? --GB
1023 adejneka 1.48 (letf (((medium-text-style medium) (make-text-style nil nil nil))
1024     ((medium-ink medium) +foreground-ink+)
1025     ((medium-clipping-region medium) +everywhere+)
1026     ((medium-transformation medium) +identity-transformation+)
1027     ((stream-cursor-position stream) (values 0 0))
1028 adejneka 1.52 ((slot-value stream 'baseline) baseline)
1029     ; FIXME:
1030     ; 1. SLOT-VALUE...
1031     ; 2. It should also save a "current line".
1032     )
1033 adejneka 1.48 (loop with offset = (- x1 initial-x1)
1034     for substring in strings
1035     do (with-slots (start-x text-style ink clipping-region string)
1036     substring
1037     (setf (stream-cursor-position stream)
1038     (values (+ start-x offset) start-y))
1039     (setf (medium-text-style medium) text-style
1040     (medium-ink medium) ink
1041     (medium-clipping-region medium) clipping-region)
1042     (stream-write-line stream string)))
1043     (when wrapped ; FIXME
1044     (draw-rectangle* medium
1045     (+ wrapped 0) start-y
1046     (+ wrapped 4) (+ start-y max-height)
1047     :ink +foreground-ink+
1048     :filled t))))))
1049 mikemac 1.1
1050 moore 1.34 (defmethod output-record-start-cursor-position
1051 adejneka 1.46 ((record standard-text-displayed-output-record))
1052 mikemac 1.1 (with-slots (start-x start-y) record
1053     (values start-x start-y)))
1054    
1055 moore 1.34 (defmethod output-record-end-cursor-position
1056 adejneka 1.46 ((record standard-text-displayed-output-record))
1057 mikemac 1.1 (with-slots (end-x end-y) record
1058     (values end-x end-y)))
1059    
1060 adejneka 1.46 (defmethod tree-recompute-extent
1061     ((text-record standard-text-displayed-output-record))
1062     (with-slots (parent x1 y1 x2 y2 width max-height) text-record
1063     (setq x2 (coordinate (+ x1 width))
1064 adejneka 1.47 y2 (coordinate (+ y1 max-height))))
1065     text-record)
1066 adejneka 1.46
1067 adejneka 1.47 (defmethod add-character-output-to-text-record ; XXX OAOO with ADD-STRING-...
1068 adejneka 1.46 ((text-record standard-text-displayed-output-record)
1069     character text-style char-width height new-baseline)
1070 adejneka 1.47 (destructuring-bind (ink clipping-region) *drawing-options* ; XXX TDO
1071     (with-slots (strings baseline width max-height start-y end-x end-y)
1072     text-record
1073     (if (and strings
1074     (let ((string (last1 strings)))
1075     (and (eq text-style (slot-value string 'text-style))
1076     (eq ink (slot-value string 'ink))
1077     (eq clipping-region
1078     (slot-value string 'clipping-region)))))
1079     (vector-push-extend character (slot-value (last1 strings) 'string))
1080     (nconcf strings
1081     (list (make-instance
1082     'styled-string
1083     :start-x end-x
1084     :text-style text-style
1085     :ink (first *drawing-options*) ; XXX TDO
1086     :clipping-region (second *drawing-options*)
1087     :string (make-array 1 :initial-element character
1088 adejneka 1.46 :element-type 'character
1089     :adjustable t
1090 adejneka 1.47 :fill-pointer t)))))
1091     (setq baseline (max baseline new-baseline)
1092     end-x (+ end-x char-width)
1093     max-height (max max-height height)
1094     end-y (max end-y (+ start-y max-height))
1095     width (+ width char-width))))
1096 adejneka 1.46 (tree-recompute-extent text-record))
1097    
1098     (defmethod add-string-output-to-text-record
1099     ((text-record standard-text-displayed-output-record)
1100     string start end text-style string-width height new-baseline)
1101     (if end
1102     (setq end (min end (length string)))
1103     (setq end (length string)))
1104     (let ((length (max 0 (- end start))))
1105     (cond
1106 adejneka 1.47 ((= length 1)
1107     (add-character-output-to-text-record text-record
1108     (aref string start)
1109     text-style
1110     string-width height new-baseline))
1111     (t
1112     (setq string (make-array length :displaced-to string ; XXX
1113     :displaced-index-offset start
1114     :element-type (array-element-type string)))
1115     (with-slots (strings baseline width max-height start-y end-x end-y)
1116     text-record
1117     (nconcf strings
1118     (list (make-instance
1119     'styled-string
1120     :start-x end-x
1121     :text-style text-style
1122     :ink (first *drawing-options*) ; XXX TDO
1123     :clipping-region (second *drawing-options*)
1124     :string (make-array (length string)
1125     :initial-contents string
1126     :element-type 'character
1127     :adjustable t
1128     :fill-pointer t))))
1129     (setq baseline (max baseline new-baseline)
1130     end-x (+ end-x string-width)
1131     max-height (max max-height height)
1132     end-y (max end-y (+ start-y max-height))
1133     width (+ width string-width)))
1134     (tree-recompute-extent text-record)))))
1135 adejneka 1.46
1136 moore 1.34 (defmethod text-displayed-output-record-string
1137 adejneka 1.46 ((record standard-text-displayed-output-record))
1138     (with-output-to-string (result)
1139     (with-slots (strings) record
1140     (loop for (nil nil substring) in strings
1141     do (write-string substring result)))))
1142    
1143     ;;; 16.3.4. Top-Level Output Records
1144     (defclass stream-output-history-mixin ()
1145     ())
1146    
1147     (defclass standard-sequence-output-history
1148     (standard-sequence-output-record stream-output-history-mixin)
1149     ())
1150 cvs 1.5
1151 adejneka 1.46 (defclass standard-tree-output-history
1152     (standard-tree-output-record stream-output-history-mixin)
1153 moore 1.34 ())
1154    
1155 adejneka 1.46 ;;; 16.4. Output Recording Streams
1156     (defclass standard-output-recording-stream (output-recording-stream)
1157     ((recording-p :initform t :reader stream-recording-p)
1158     (drawing-p :initform t :accessor stream-drawing-p)
1159     (output-history :initform (make-instance 'standard-tree-output-history)
1160     :reader stream-output-history)
1161     (current-output-record :accessor stream-current-output-record)
1162     (current-text-output-record :initform nil
1163     :accessor stream-current-text-output-record)
1164     (local-record-p :initform t
1165     :documentation "This flag is used for dealing with streams outputting strings char-by-char.")))
1166    
1167     (defmethod initialize-instance :after
1168     ((stream standard-output-recording-stream) &rest args)
1169     (declare (ignore args))
1170     (setf (stream-current-output-record stream) (stream-output-history stream)))
1171    
1172     ;;; 16.4.1 The Output Recording Stream Protocol
1173     (defmethod (setf stream-recording-p)
1174     (recording-p (stream standard-output-recording-stream))
1175     (let ((old-val (slot-value stream 'recording-p)))
1176     (setf (slot-value stream 'recording-p) recording-p)
1177     (when (not (eq old-val recording-p))
1178     (stream-close-text-output-record stream))
1179     recording-p))
1180    
1181     (defmethod stream-add-output-record
1182     ((stream standard-output-recording-stream) record)
1183     (add-output-record record (stream-current-output-record stream)))
1184    
1185     (defmethod stream-replay
1186     ((stream standard-output-recording-stream) &optional region)
1187     (replay (stream-output-history stream) stream region))
1188    
1189 adejneka 1.47 (defun output-record-ancestor-p (ancestor child)
1190     (loop for record = child then parent
1191     for parent = (output-record-parent record)
1192     when (eq parent nil) do (return nil)
1193     when (eq parent ancestor) do (return t)))
1194    
1195 adejneka 1.46 (defmethod erase-output-record (record (stream standard-output-recording-stream)
1196     &optional (errorp t))
1197     (letf (((stream-recording-p stream) nil))
1198     (let ((region (bounding-rectangle record)))
1199     (with-bounding-rectangle* (x1 y1 x2 y2) region
1200 adejneka 1.47 (if (output-record-ancestor-p (stream-output-history stream) record)
1201     (progn
1202     (delete-output-record record (output-record-parent record))
1203 adejneka 1.49 (with-output-recording-options (stream :record nil)
1204     (draw-rectangle* stream x1 y1 x2 y2 :ink +background-ink+))
1205 adejneka 1.47 (stream-replay stream region))
1206     (when errorp
1207     (error "~S is not contained in ~S." record stream)))))))
1208 adejneka 1.46
1209     (defun copy-textual-output-history (window stream &optional region record)
1210     ;; FIXME
1211     (declare (ignore window stream region record))
1212     (error "Not implemented."))
1213    
1214     ;;; 16.4.3. Text Output Recording
1215     (defmethod stream-text-output-record
1216     ((stream standard-output-recording-stream) text-style)
1217 mikemac 1.30 (declare (ignore text-style))
1218 adejneka 1.20 (let ((record (stream-current-text-output-record stream)))
1219 adejneka 1.47 (unless (and record (typep record 'standard-text-displayed-output-record))
1220     (multiple-value-bind (cx cy) (stream-cursor-position stream)
1221     (setf record (make-instance 'standard-text-displayed-output-record
1222     :x-position cx :y-position cy
1223     :start-x cx :start-y cy)
1224     (stream-current-text-output-record stream) record)))
1225 adejneka 1.20 record))
1226    
1227 adejneka 1.46 (defmethod stream-close-text-output-record
1228     ((stream standard-output-recording-stream))
1229 adejneka 1.20 (let ((record (stream-current-text-output-record stream)))
1230     (when record
1231     (setf (stream-current-text-output-record stream) nil)
1232     #|record stream-current-cursor-position to (end-x record) - already done|#
1233     (stream-add-output-record stream record))))
1234    
1235 adejneka 1.46 (defmethod stream-add-character-output
1236     ((stream standard-output-recording-stream)
1237     character text-style width height baseline)
1238     (add-character-output-to-text-record
1239     (stream-text-output-record stream text-style)
1240     character text-style width height baseline))
1241 adejneka 1.20
1242 adejneka 1.22 (defmethod stream-add-string-output ((stream standard-output-recording-stream)
1243 adejneka 1.20 string start end text-style
1244     width height baseline)
1245 adejneka 1.46 (add-string-output-to-text-record (stream-text-output-record stream
1246     text-style)
1247 adejneka 1.20 string start end text-style
1248     width height baseline))
1249    
1250 adejneka 1.46 ;;; Text output catching methods
1251 adejneka 1.20 (defmacro without-local-recording (stream &body body)
1252 adejneka 1.22 `(letf (((slot-value ,stream 'local-record-p) nil))
1253 adejneka 1.47 ,@body))
1254 adejneka 1.22
1255 adejneka 1.46 (defmethod stream-write-line :around
1256     ((stream standard-output-recording-stream) line)
1257 adejneka 1.22 (when (and (stream-recording-p stream)
1258     (slot-value stream 'local-record-p))
1259     (let* ((medium (sheet-medium stream))
1260 adejneka 1.47 (text-style (medium-text-style medium))
1261     (*drawing-options* (list (medium-ink medium) ; XXX TDO
1262     (medium-clipping-region medium))))
1263 adejneka 1.22 (stream-add-string-output stream line 0 nil text-style
1264     (stream-string-width stream line
1265     :text-style text-style)
1266 strandh 1.26 (text-style-height text-style medium)
1267     (text-style-ascent text-style medium))))
1268 adejneka 1.22 (when (stream-drawing-p stream)
1269     (without-local-recording stream
1270     (call-next-method))))
1271 cvs 1.5
1272 adejneka 1.22 #+nil
1273     (defmethod stream-write-char :around ((stream standard-output-recording-stream) char)
1274 adejneka 1.20 (when (and (stream-recording-p stream)
1275     (slot-value stream 'local-record-p))
1276     (if (or (eql char #\return)
1277     (eql char #\newline))
1278     (stream-close-text-output-record stream)
1279 cvs 1.8 (let* ((medium (sheet-medium stream))
1280 strandh 1.26 (text-style (medium-text-style medium)))
1281 adejneka 1.20 (stream-add-character-output stream char text-style
1282     (stream-character-width stream char :text-style text-style)
1283 strandh 1.26 (text-style-height text-style medium)
1284     (text-style-ascent text-style medium)))))
1285 adejneka 1.20 (without-local-recording stream
1286     (call-next-method)))
1287    
1288 adejneka 1.21 #+nil
1289 adejneka 1.22 (defmethod stream-write-string :around ((stream standard-output-recording-stream) string
1290 adejneka 1.20 &optional (start 0) end)
1291 adejneka 1.21 ;; Problem: it is necessary to check for line wrapping. Now the
1292     ;; default method for STREAM-WRITE-STRING do char-by-char output,
1293     ;; therefore STREAM-WRITE-CHAR can do the right thing.
1294 adejneka 1.20 (when (and (stream-recording-p stream)
1295     (slot-value stream 'local-record-p))
1296     (let* ((medium (sheet-medium stream))
1297 strandh 1.26 (text-style (medium-text-style medium)))
1298 adejneka 1.20 (stream-add-string-output stream string start end text-style
1299     (stream-string-width stream string
1300     :start start :end end
1301     :text-style text-style)
1302 strandh 1.26 (text-style-height text-style medium)
1303     (text-style-ascent text-style medium))))
1304 adejneka 1.20 (without-local-recording stream
1305     (call-next-method)))
1306 adejneka 1.41
1307 adejneka 1.20
1308 adejneka 1.22 (defmethod stream-finish-output :after ((stream standard-output-recording-stream))
1309 adejneka 1.20 (stream-close-text-output-record stream))
1310    
1311 adejneka 1.22 (defmethod stream-force-output :after ((stream standard-output-recording-stream))
1312 adejneka 1.20 (stream-close-text-output-record stream))
1313    
1314 adejneka 1.22 (defmethod stream-terpri :after ((stream standard-output-recording-stream))
1315 adejneka 1.21 (stream-close-text-output-record stream))
1316    
1317 rouanet 1.23 (defmethod* (setf stream-cursor-position) :after (x y (stream standard-output-recording-stream))
1318 mikemac 1.30 (declare (ignore x y))
1319 adejneka 1.20 (stream-close-text-output-record stream))
1320    
1321 adejneka 1.22 ;(defmethod stream-set-cursor-position :after ((stream standard-output-recording-stream))
1322 adejneka 1.20 ; (stream-close-text-output-record stream))
1323 cvs 1.5
1324 adejneka 1.22 (defmethod stream-wrap-line :before ((stream standard-output-recording-stream))
1325 cvs 1.5 (when (stream-recording-p stream)
1326 adejneka 1.20 (setf (text-record-wrapped (stream-text-output-record stream nil)) ; FIXME!
1327     (stream-text-margin stream))))
1328 adejneka 1.46
1329     ;;; 16.4.4. Output Recording Utilities
1330    
1331     (defmethod invoke-with-output-recording-options
1332     ((stream output-recording-stream) continuation record draw)
1333     "Calls CONTINUATION on STREAM enabling or disabling recording and drawing
1334     according to the flags RECORD and DRAW."
1335     (letf (((stream-recording-p stream) record)
1336     ((stream-drawing-p stream) draw))
1337     (funcall continuation stream)))
1338    
1339     (defmethod invoke-with-new-output-record ((stream output-recording-stream)
1340     continuation record-type
1341     &rest initargs
1342 adejneka 1.50 &key
1343 adejneka 1.46 &allow-other-keys)
1344     (stream-close-text-output-record stream)
1345 adejneka 1.47 (let ((new-record (apply #'make-instance record-type initargs)))
1346 adejneka 1.46 (letf (((stream-current-output-record stream) new-record))
1347     ;; Should we switch on recording? -- APD
1348     (funcall continuation stream new-record)
1349     (finish-output stream))
1350     (stream-add-output-record stream new-record)
1351     new-record))
1352    
1353     (defmethod invoke-with-output-to-output-record
1354     ((stream output-recording-stream) continuation record-type
1355     &rest initargs
1356 adejneka 1.50 &key
1357 adejneka 1.46 &allow-other-keys)
1358     (stream-close-text-output-record stream)
1359 adejneka 1.47 (let ((new-record (apply #'make-instance record-type initargs)))
1360 adejneka 1.46 (with-output-recording-options (stream :record t :draw nil)
1361 adejneka 1.48 (letf (((stream-current-output-record stream) new-record)
1362     ((stream-cursor-position stream) (values 0 0)))
1363     (funcall continuation stream new-record)
1364     (finish-output stream)))
1365 adejneka 1.46 new-record))
1366    
1367     (defmethod make-design-from-output-record (record)
1368     ;; FIXME
1369     (declare (ignore record))
1370     (error "Not implemented."))
1371    
1372    
1373     ;;; Additional methods
1374     (defmethod scroll-vertical :around ((stream output-recording-stream) dy)
1375     (declare (ignore dy))
1376     (with-output-recording-options (stream :record nil)
1377     (call-next-method)))
1378    
1379     (defmethod scroll-horizontal :around ((stream output-recording-stream) dx)
1380     (declare (ignore dx))
1381     (with-output-recording-options (stream :record nil)
1382     (call-next-method)))
1383    
1384     (defmethod handle-repaint ((stream output-recording-stream) region)
1385     (stream-replay stream region))
1386    
1387     #|
1388     (defmethod handle-event :after ((stream output-recording-stream) (event pointer-button-press-event))
1389     (highlight-output-record (stream-current-output-record stream) stream :highlight))
1390    
1391     (defmethod handle-event :before ((stream output-recording-stream) (event pointer-button-release-event))
1392     (highlight-output-record (stream-current-output-record stream) stream :unhighlight))
1393     |#

  ViewVC Help
Powered by ViewVC 1.1.5