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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5