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

Contents of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.54 - (hide annotations)
Tue Sep 24 01:56:30 2002 UTC (11 years, 6 months ago) by moore
Branch: MAIN
Changes since 1.53: +105 -97 lines
Fixed bug reported by Paul Werkowski; coordinate sequences can now be
lists or vectors.  Introduced a do-sequence macro that has similar
semantics to dotimes and dolist as well as features of map-sequence.

Implemented frame-state (except for :shrunk).  Changed timing of when
frames are generated, adopted and enabled to follow the spec.  Fixed
clim-fig to adapt to this new world order.  Disable the frame when the
top level function exits.

Remove erroring methods for copy-to-pixmap (stream ...) and friends.

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

  ViewVC Help
Powered by ViewVC 1.1.5