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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.49 - (hide annotations)
Sun Jun 16 06:52:08 2002 UTC (11 years, 10 months ago) by adejneka
Branch: MAIN
Changes since 1.48: +83 -70 lines
* WITH-NEW-OUTPUT-RECORD, WITH-OUTPUT-TO-OUTPUT-RECORD: RECORD
  argument is evaluated.

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

  ViewVC Help
Powered by ViewVC 1.1.5