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

Diff of /mcclim/recording.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1.1.1 by mikemac, Thu Jun 8 22:01:12 2000 UTC revision 1.145 by gbaumann, Sat Aug 1 16:10:32 2009 UTC
# Line 1  Line 1 
1  ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-  ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2    
3  ;;;  (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com)  ;;;  (c) copyright 1998,1999,2000,2001 by Michael McDonald (mikemac@mikemac.com)
4    ;;;  (c) copyright 2000 by
5    ;;;           Robert Strandh (strandh@labri.u-bordeaux.fr)
6    ;;;  (c) copyright 2001 by
7    ;;;           Arnaud Rouanet (rouanet@emi.u-bordeaux.fr)
8    ;;;           Lionel Salabartan (salabart@emi.u-bordeaux.fr)
9    ;;;  (c) copyright 2001, 2002 by Alexey Dejneka (adejneka@comail.ru)
10    ;;;  (c) copyright 2003 by Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
11    
12  ;;; This library is free software; you can redistribute it and/or  ;;; This library is free software; you can redistribute it and/or
13  ;;; modify it under the terms of the GNU Library General Public  ;;; modify it under the terms of the GNU Library General Public
# Line 13  Line 20 
20  ;;; Library General Public License for more details.  ;;; Library General Public License for more details.
21  ;;;  ;;;
22  ;;; You should have received a copy of the GNU Library General Public  ;;; You should have received a copy of the GNU Library General Public
23  ;;; License along with this library; if not, write to the  ;;; License along with this library; if not, write to the
24  ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,  ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25  ;;; Boston, MA  02111-1307  USA.  ;;; Boston, MA  02111-1307  USA.
26    
27  (in-package :CLIM-INTERNALS)  ;;; TODO:
28    ;;;
29    ;;; - Scrolling does not work correctly. Region is given in "window"
30    ;;; coordinates, without bounding-rectangle-position transformation.
31    ;;; (Is it still valid?)
32    ;;;
33    ;;; - Redo setf*-output-record-position, extent recomputation for
34    ;;; compound records
35    ;;;
36    ;;; - When DRAWING-P is NIL, should stream cursor move?
37    ;;;
38    ;;; - :{X,Y}-OFFSET.
39    ;;;
40    ;;; - (SETF OUTPUT-RECORD-START-CURSOR-POSITION) does not affect the
41    ;;; bounding rectangle. What does it affect?
42    ;;;
43    ;;; - How should (SETF OUTPUT-RECORD-POSITION) affect the bounding
44    ;;; rectangle of the parent? Now its bounding rectangle is accurately
45    ;;; recomputed, but it is very inefficient for table formatting. It
46    ;;; seems that CLIM is supposed to keep a "large enougn" rectangle and
47    ;;; to shrink it to the correct size only when the layout is complete
48    ;;; by calling TREE-RECOMPUTE-EXTENT.
49    ;;;
50    ;;; - Computation of the bounding rectangle of lines/polygons ignores
51    ;;; LINE-STYLE-CAP-SHAPE.
52    ;;;
53    ;;; - Rounding of coordinates.
54    ;;;
55    ;;; - Document carefully the interface of
56    ;;; STANDARD-OUTPUT-RECORDING-STREAM.
57    ;;;
58    ;;; - COORD-SEQ is a sequence, not a list.
59    
60    ;;; Troubles
61    
62    ;;; DC
63    ;;;
64    ;;; Some GFs are defined to have "a default method on CLIM's standard
65    ;;; output record class". What does it mean? What is "CLIM's standard
66    ;;; output record class"? Is it OUTPUT-RECORD or BASIC-OUTPUT-RECORD?
67    ;;; Now they are defined on OUTPUT-RECORD.
68    
69    
70    (in-package :clim-internals)
71    
72    ;;; 16.2.1. The Basic Output Record Protocol
73    #+:cmu(declaim (ftype (function (output-record) (values rational rational))
74                          output-record-position))
75    ;; XXX What does #+:CMU mean? FTYPE was excluded from ANSI CL? Other
76    ;; compilers try to check type declarations?
77    (defgeneric output-record-position (record)
78      (:documentation
79       "Returns the x and y position of RECORD. The position is the
80    position of the upper-left corner of its bounding rectangle. The
81    position is relative to the stream, where (0,0) is (initially) the
82    upper-left corner of the stream."))
83    
84    (defgeneric* (setf output-record-position) (x y record)
85      (:documentation
86       "Changes the x and y position of the RECORD to be X and Y, and
87    updates the bounding rectangle to reflect the new position (and saved
88    cursor positions, if the output record stores it). If RECORD has any
89    children, all of the children (and their descendants as well) will be
90    moved by the same amount as RECORD was moved. The bounding rectangles
91    of all of RECORD's ancestors will also be updated to be large enough
92    to contain RECORD."))
93    
94    #+:cmu(declaim (ftype (function (output-record) (values integer integer))
95                          output-record-start-cursor-position))
96    (defgeneric output-record-start-cursor-position (record)
97      (:documentation
98       "Returns the x and y starting cursor position of RECORD. The
99    positions are relative to the stream, where (0,0) is (initially) the
100    upper-left corner of the stream."))
101    
102    (defgeneric* (setf output-record-start-cursor-position) (x y record))
103    
104    #+:cmu(declaim (ftype (function (output-record) (values integer integer))
105                          output-record-end-cursor-position))
106    (defgeneric output-record-end-cursor-position (record)
107      (:documentation
108       "Returns the x and y ending cursor position of RECORD. The
109    positions are relative to the stream, where (0,0) is (initially) the
110    upper-left corner of the stream."))
111    
112    (defgeneric* (setf output-record-end-cursor-position) (x y record))
113    
114    (defgeneric output-record-parent (record)
115      (:documentation
116       "Returns the output record that is the parent of RECORD, or NIL if
117    RECORD has no parent."))
118    
119    (defgeneric (setf output-record-parent) (parent record)
120      (:documentation "Non-standard function."))
121    
122    (defgeneric replay-output-record (record stream
123                                      &optional region x-offset y-offset)
124      (:documentation "Displays the output captured by RECORD on the
125    STREAM, exactly as it was originally captured. The current user
126    transformation, line style, text style, ink and clipping region of
127    STREAM are all ignored. Instead, these are gotten from the output
128    record.
129    
130    Only those records that overlap REGION are displayed."))
131    
132    (defgeneric output-record-hit-detection-rectangle* (record))
133    
134    (defgeneric output-record-refined-position-test (record x y))
135    
136    (defgeneric highlight-output-record (record stream state))
137    
138    (defgeneric displayed-output-record-ink (displayed-output-record))
139    
140    ;;; 16.2.2. Output Record "Database" Protocol
141    
142    (defgeneric output-record-children (record))
143    
144    (defgeneric add-output-record (child record))
145    
146    (defgeneric delete-output-record (child record &optional errorp))
147    
148    (defgeneric clear-output-record (record))
149    
150    (defgeneric output-record-count (record))
151    
152    (defgeneric map-over-output-records-containing-position
153      (function record x y &optional x-offset y-offset &rest function-args)
154      (:documentation "Maps over all of the children of RECORD that
155    contain the point at (X,Y), calling FUNCTION on each one. FUNCTION is
156    a function of one or more arguments, the first argument being the
157    record containing the point. FUNCTION is also called with all of
158    FUNCTION-ARGS as APPLY arguments.
159    
160    If there are multiple records that contain the point,
161    MAP-OVER-OUTPUT-RECORDS-CONTAINING-POSITION hits the most recently
162    inserted record first and the least recently inserted record
163    last. Otherwise, the order in which the records are traversed is
164    unspecified."))
165    
166    (defgeneric map-over-output-records-overlapping-region
167      (function record region &optional x-offset y-offset &rest function-args)
168      (:documentation "Maps over all of the children of the RECORD that
169    overlap the REGION, calling FUNCTION on each one. FUNCTION is a
170    function of one or more arguments, the first argument being the record
171    overlapping the region. FUNCTION is also called with all of
172    FUNCTION-ARGS as APPLY arguments.
173    
174    If there are multiple records that overlap the region and that overlap
175    each other, MAP-OVER-OUTPUT-RECORDS-OVERLAPPING-REGION hits the least
176    recently inserted record first and the most recently inserted record
177    last. Otherwise, the order in which the records are traversed is
178    unspecified. "))
179    
180    ;;; From the Franz CLIM user's guide but not in the spec... clearly necessary.
181    
182  (defclass output-record (standard-bounding-rectangle)  (defgeneric map-over-output-records-1
183        (continuation record continuation-args))
184    
185    (defun map-over-output-records
186        (continuation record &optional x-offset y-offset &rest continuation-args)
187      (declare (ignore x-offset y-offset))
188      (map-over-output-records-1 continuation record continuation-args))
189    
190    ;;; 16.2.3. Output Record Change Notification Protocol
191    
192    (defgeneric recompute-extent-for-new-child (record child))
193    
194    (defgeneric recompute-extent-for-changed-child
195      (record child old-min-x old-min-y old-max-x old-max-y))
196    
197    (defgeneric tree-recompute-extent (record))
198    
199    ;;; 21.3 Incremental Redisplay Protocol.  These generic functions need
200    ;;; to be implemented for all the basic displayed-output-records, so they are
201    ;;; defined in this file.
202    ;;;
203    ;;; match-output-records and find-child-output-record, as defined in
204    ;;; the CLIM spec, are pretty silly.  How does incremental redisplay know
205    ;;; what keyword arguments to supply to find-child-output-record?  Through
206    ;;; a gf specialized on the type of the record it needs to match... why
207    ;;; not define the search function and the predicate on two records then!
208    ;;;
209    ;;; We'll implement match-output-records and find-child-output-record,
210    ;;; but we won't actually use them.  Instead, output-record-equal will
211    ;;; match two records, and find-child-record-equal will search for the
212    ;;; equivalent record.
213    
214    (defgeneric match-output-records (record &rest args))
215    
216    ;;; These gf's use :most-specific-last because one of the least
217    ;;; specific methods will check the bounding boxes of the records, which
218    ;;; should cause an early out most of the time.
219    
220    (defgeneric match-output-records-1 (record &key)
221      (:method-combination and :most-specific-last))
222    
223    (defgeneric output-record-equal (record1 record2)
224      (:method-combination and :most-specific-last))
225    
226    (defmethod output-record-equal :around (record1 record2)
227      (cond ((eq record1 record2)
228             ;; Some unusual record -- like a Goatee screen line -- might
229             ;; exist in two trees at once
230             t)
231            ((eq (class-of record1) (class-of record2))
232             (let ((result (call-next-method)))
233               (if (eq result 'maybe)
234                   nil
235                   result)))
236            (t nil)))
237    
238    ;;; A fallback method so that something's always applicable.
239    
240    (defmethod output-record-equal and (record1 record2)
241      (declare (ignore record1 record2))
242      'maybe)
243    
244    ;;; The code for match-output-records-1 and output-record-equal
245    ;;; methods are very similar, hence this macro.  In order to exploit
246    ;;; the similarities, it's necessary to treat the slots of the second
247    ;;; record like variables, so for convenience the macro will use
248    ;;; slot-value on both records.
249    
250    (defmacro defrecord-predicate (record-type slots &body body)
251      "Each element of SLOTS is either a symbol or (:initarg-name slot-name)."
252      (let* ((slot-names (mapcar #'(lambda (slot-spec)
253                                     (if (consp slot-spec)
254                                         (cadr slot-spec)
255                                         slot-spec))
256                                 slots))
257             (supplied-vars (mapcar #'(lambda (slot)
258                                        (gensym (symbol-name
259                                                 (symbol-concat slot '#:-p))))
260                                    slot-names))
261             (key-args (mapcar #'(lambda (slot-spec supplied)
262                                   `(,slot-spec nil ,supplied))
263                               slots supplied-vars))
264             (key-arg-alist (mapcar #'cons slot-names supplied-vars)))
265        `(progn
266           (defmethod output-record-equal and ((record ,record-type)
267                                               (record2 ,record-type))
268             (macrolet ((if-supplied ((var &optional (type t)) &body supplied-body)
269                          (declare (ignore var type))
270                          `(progn ,@supplied-body)))
271               (with-slots ,slot-names
272                   record2
273                 ,@body)))
274           (defmethod match-output-records-1 and ((record ,record-type)
275                                                  &key ,@key-args)
276             (macrolet ((if-supplied ((var &optional (type t)) &body supplied-body)
277                          (let ((supplied-var (cdr (assoc var ',key-arg-alist))))
278                            (unless supplied-var
279                              (error "Unknown slot ~S" var))
280                            `(or (null ,supplied-var)
281                                 ,@(if (eq type t)
282                                       `((progn ,@supplied-body))
283                                       `((if (typep ,var ',type)
284                                             (progn ,@supplied-body)
285                                             (error 'type-error
286                                                    :datum ,var
287                                                    :expected-type ',type))))))))
288               ,@body)))
289    
290        ))
291    ;;; Macros
292    (defmacro with-output-recording-options ((stream
293                                              &key (record nil record-supplied-p)
294                                                   (draw nil draw-supplied-p))
295                                             &body body)
296      (setq stream (stream-designator-symbol stream '*standard-output*))
297      (with-gensyms (continuation)
298        `(flet ((,continuation  (,stream)
299                  ,(declare-ignorable-form* stream)
300                  ,@body))
301           (declare (dynamic-extent #',continuation))
302           (invoke-with-output-recording-options
303            ,stream #',continuation
304            ,(if record-supplied-p record `(stream-recording-p ,stream))
305            ,(if draw-supplied-p draw `(stream-drawing-p ,stream))))))
306    
307    ;;; Macro masturbation...
308    
309    (defmacro define-invoke-with (macro-name func-name record-type doc-string)
310      `(defmacro ,macro-name ((stream
311                               &optional
312                               (record-type '',record-type)
313                               (record (gensym))
314                               &rest initargs)
315                              &body body)
316         ,doc-string
317         (setq stream (stream-designator-symbol stream '*standard-output*))
318         (with-gensyms (constructor continuation)
319           (multiple-value-bind (bindings m-i-args)
320               (rebind-arguments initargs)
321             `(let ,bindings
322                (flet ((,constructor ()
323                         (make-instance ,record-type ,@m-i-args))
324                       (,continuation (,stream ,record)
325                         ,(declare-ignorable-form* stream record)
326                         ,@body))
327                  (declare (dynamic-extent #',constructor #',continuation))
328                  (,',func-name ,stream #',continuation ,record-type #',constructor
329                                ,@m-i-args)))))))
330    
331    (define-invoke-with with-new-output-record invoke-with-new-output-record
332      standard-sequence-output-record
333      "Creates a new output record of type RECORD-TYPE and then captures
334    the output of BODY into the new output record, and inserts the new
335    record into the current \"open\" output record assotiated with STREAM.
336        If RECORD is supplied, it is the name of a variable that will be
337    lexically bound to the new output record inside the body. INITARGS are
338    CLOS initargs that are passed to MAKE-INSTANCE when the new output
339    record is created.
340        It returns the created output record.
341        The STREAM argument is a symbol that is bound to an output
342    recording stream. If it is T, *STANDARD-OUTPUT* is used.")
343    
344    (define-invoke-with with-output-to-output-record
345        invoke-with-output-to-output-record
346      standard-sequence-output-record
347      "Creates a new output record of type RECORD-TYPE and then captures
348    the output of BODY into the new output record. The cursor position of
349    STREAM is initially bound to (0,0)
350        If RECORD is supplied, it is the name of a variable that will be
351    lexically bound to the new output record inside the body. INITARGS are
352    CLOS initargs that are passed to MAKE-INSTANCE when the new output
353    record is created.
354        It returns the created output record.
355        The STREAM argument is a symbol that is bound to an output
356    recording stream. If it is T, *STANDARD-OUTPUT* is used.")
357    
358    
359    ;;;; Implementation
360    
361    (defclass basic-output-record (standard-bounding-rectangle output-record)
362      ((parent :initarg :parent ; XXX
363               :initform nil
364               :accessor output-record-parent)) ; XXX
365      (:documentation "Implementation class for the Basic Output Record Protocol."))
366    
367    (defmethod initialize-instance :after ((record basic-output-record)
368                                           &key (x-position 0.0d0)
369                                                (y-position 0.0d0))
370      (setf (rectangle-edges* record)
371            (values x-position y-position x-position y-position)))
372    
373    ;;; XXX I'd really like to get rid of the x and y slots. They are surely
374    ;;; redundant with the bounding rectangle coordinates.
375    (defclass compound-output-record (basic-output-record)
376    ((x :initarg :x-position    ((x :initarg :x-position
377        :initform 0)        :initform 0.0d0
378          :documentation "X-position of the empty record.")
379     (y :initarg :y-position     (y :initarg :y-position
380        :initform 0)        :initform 0.0d0
381     (parent :initarg :parent        :documentation "Y-position of the empty record.")
382             :initform nil)     (in-moving-p :initform nil
383     (children :initform nil                  :documentation "Is set while changing the position."))
384               :reader output-record-children)    (:documentation "Implementation class for output records with children."))
385     )  
386    (:default-initargs :min-x 0 :min-y 0 :max-x 0 :max-y 0))  ;;; 16.2.1. The Basic Output Record Protocol
387    (defmethod output-record-position ((record basic-output-record))
388  (defun output-record-p (x)    (bounding-rectangle-position record))
389    (typep x 'output-record))  
390    (defmethod* (setf output-record-position) (nx ny (record basic-output-record))
391  (defclass displayed-output-record (output-record)    (with-standard-rectangle (x1 y1 x2 y2)
392    (       record
393     ))      (let ((dx (- nx x1))
394              (dy (- ny y1)))
395  (defun displayed-output-record-p (x)        (setf (rectangle-edges* record)
396    (typep x 'displayed-output-record))              (values nx ny (+ x2 dx) (+ y2 dy)))))
397      (values nx ny))
398  (defmethod initialize-instance :after ((record displayed-output-record) &rest args  
399                                         &key size  (defmethod* (setf output-record-position) :around
400                                         &allow-other-keys)              (nx ny (record basic-output-record))
401    (declare (ignore args size)))    (with-bounding-rectangle* (min-x min-y max-x max-y) record
402        (call-next-method)
403        (let ((parent (output-record-parent record)))
404          (when (and parent (not (and (typep parent 'compound-output-record)
405                                      (slot-value parent 'in-moving-p)))) ; XXX
406            (recompute-extent-for-changed-child parent record
407                                                min-x min-y max-x max-y)))
408        (values nx ny)))
409    
410    (defmethod* (setf output-record-position)
411      :before (nx ny (record compound-output-record))
412      (with-standard-rectangle* (:x1 x1 :y1 y1)
413          record
414        (letf (((slot-value record 'in-moving-p) t))
415          (let ((dx (- nx x1))
416                (dy (- ny y1)))
417            (map-over-output-records
418             (lambda (child)
419               (multiple-value-bind (x y) (output-record-position child)
420                 (setf (output-record-position child)
421                       (values (+ x dx) (+ y dy)))))
422             record)))))
423    
424  (defmethod output-record-position ((record displayed-output-record))  (defmethod output-record-start-cursor-position ((record basic-output-record))
425    (with-slots (x y) record    (values nil nil))
     (values x y)))  
426    
427  (defmethod setf*-output-record-position (nx ny (record displayed-output-record))  (defmethod* (setf output-record-start-cursor-position)
428    (with-slots (x y) record      (x y (record basic-output-record))
429      (setq x nx    (values x y))
           y ny)))  
430    
431  (defmethod output-record-start-cursor-position ((record displayed-output-record))  (defmethod output-record-end-cursor-position ((record basic-output-record))
432    (values nil nil))    (values nil nil))
433    
434  (defmethod setf*-output-record-start-cursor-position (x y (record displayed-output-record))  (defmethod* (setf output-record-end-cursor-position)
435        (x y (record basic-output-record))
436      (values x y))
437    
438    #+cmu
439    (progn
440      ;; Sometimes CMU's PCL fails with forward reference classes, so this
441      ;; is a kludge to keep it happy.
442      ;;
443      ;; This was reported as a bug to cmucl-imp [<E18vKN1-0004DQ-00@saphir.local>]
444      ;;
445      ;; In short it exposes itself when you compile and load into a
446      ;; _virgin_ lisp the following:
447      ;;
448      ;;   (defclass foo (bar) ())
449      ;;   (defun barz () (make-instance 'foo))
450      ;;   (defclass bar () ())
451      ;;
452      ;; --GB 2003-03-18
453      ;;
454      (defclass gs-ink-mixin () ())
455      (defclass gs-clip-mixin () ())
456      (defclass gs-line-style-mixin () ())
457      (defclass gs-text-style-mixin () ()))
458    
459    ;;; Humph. It'd be nice to tie this to the actual definition of a
460    ;;; medium. -- moore
461    (defclass complete-medium-state
462        (gs-ink-mixin gs-clip-mixin gs-line-style-mixin gs-text-style-mixin)
463      ())
464    
465    (defun replay (record stream &optional (region (or (pane-viewport-region stream)
466                                                       (sheet-region stream))))
467      (if (typep stream 'encapsulating-stream)
468          (replay record (encapsulating-stream-stream stream) region)
469          (progn
470            (stream-close-text-output-record stream)
471            (when (stream-drawing-p stream)
472              (with-cursor-off stream ;;FIXME?
473                (letf (((stream-cursor-position stream) (values 0 0))
474                       ((stream-recording-p stream) nil)
475                       ;; Is there a better value to bind to baseline?
476                       ((slot-value stream 'baseline) (slot-value stream 'baseline)))
477                  (with-sheet-medium (medium stream)
478                    (let ((transformation (medium-transformation medium)))
479                      (unwind-protect
480                           (progn
481                             (setf (medium-transformation medium)
482                                   +identity-transformation+)
483                             (replay-output-record record stream region))
484                        (setf (medium-transformation medium) transformation))))))))))
485    
486    (defmethod replay-output-record ((record compound-output-record) stream
487                                     &optional region (x-offset 0) (y-offset 0))
488      (when (null region)
489        (setq region (or (pane-viewport-region stream) +everywhere+)))
490      (with-drawing-options (stream :clipping-region region)
491        (map-over-output-records-overlapping-region
492         #'replay-output-record record region x-offset y-offset
493         stream region x-offset y-offset)))
494    
495    (defmethod output-record-hit-detection-rectangle* ((record output-record))
496      ;; XXX DC
497      (bounding-rectangle* record))
498    
499    (defmethod output-record-refined-position-test ((record basic-output-record)
500                                                    x y)
501    (declare (ignore x y))    (declare (ignore x y))
502      t)
503    
504    (defun highlight-output-record-rectangle (record stream state)
505      (with-identity-transformation (stream)
506        (multiple-value-bind (x1 y1 x2 y2)
507            (output-record-hit-detection-rectangle* record)
508          (ecase state
509            (:highlight
510             (draw-rectangle* (sheet-medium stream) x1 y1 (1- x2) (1- y2)
511                              :filled nil :ink +foreground-ink+)) ; XXX +FLIPPING-INK+?
512            (:unhighlight
513             ;; FIXME: repaint the hit detection rectangle. It could be bigger than
514             ;; the bounding rectangle.
515             (repaint-sheet stream record)
516    
517             ;; Using queue-repaint should be faster in apps (such as clouseau) that
518             ;; highlight/unhighlight many bounding rectangles at once. The event
519             ;; code should merge these into a single larger repaint. Unfortunately,
520             ;; since an enqueued repaint does not occur immediately, and highlight
521             ;; rectangles are not recorded, newer highlighting gets wiped out
522             ;; shortly after being drawn. So, we aren't ready for this yet.
523             ;; ..Actually, it isn't necessarily faster. Depends on the app.
524             #+NIL
525             (queue-repaint stream (make-instance 'window-repaint-event
526                                                  :sheet stream
527                                                  :region (transform-region
528                                                           (sheet-native-transformation stream)
529                                                           record))))))))
530    
531    ;;; XXX Should this only be defined on recording streams?
532    (defmethod highlight-output-record ((record output-record) stream state)
533      ;; XXX DC
534      ;; XXX Disable recording?
535      (highlight-output-record-rectangle record stream state))
536    
537    ;;; 16.2.2. The Output Record "Database" Protocol
538    
539    ;; These two aren't in the spec, but are needed to make indirect adding/deleting
540    ;; of GADGET-OUTPUT-RECORDs work:
541    
542    (defgeneric note-output-record-lost-sheet (record sheet))
543    (defgeneric note-output-record-got-sheet  (record sheet))
544    
545    (defmethod note-output-record-lost-sheet ((record output-record) sheet)
546      (declare (ignore record sheet))
547      (values))
548    
549    (defmethod note-output-record-lost-sheet :after ((record compound-output-record) sheet)
550      (map-over-output-records #'note-output-record-lost-sheet record 0 0 sheet))
551    
552    (defmethod note-output-record-got-sheet  ((record output-record) sheet)
553      (declare (ignore record sheet))
554      (values))
555    
556    (defmethod note-output-record-got-sheet :after ((record compound-output-record) sheet)
557      (map-over-output-records #'note-output-record-got-sheet record 0 0 sheet))
558    
559    (defun find-output-record-sheet (record)
560      "Walks up the parents of RECORD, searching for an output history from which
561    the associated sheet can be determined."
562      (typecase record
563        (stream-output-history-mixin (output-history-stream record))
564        (basic-output-record (find-output-record-sheet (output-record-parent record)))))
565    
566    (defmethod output-record-children ((record basic-output-record))
567    nil)    nil)
568    
569  (defmethod output-record-end-cursor-position ((record displayed-output-record))  (defmethod add-output-record (child (record basic-output-record))
570    (values nil nil))    (declare (ignore child))
571      (error "Cannot add a child to ~S." record))
572    
573    (defmethod add-output-record :before (child (record compound-output-record))
574      (let ((parent (output-record-parent child)))
575        (cond (parent
576               (restart-case
577                   (error "~S already has a parent ~S." child parent)
578                 (delete ()
579                   :report "Delete from the old parent."
580                   (delete-output-record child parent))))
581              ((eq record child)
582               (error "~S is being added to itself" record))
583              ((eq (output-record-parent record) child)
584               (error "child ~S is being added to its own child ~S"
585                      child record)))))
586    
587    (defmethod add-output-record :after (child (record compound-output-record))
588      (recompute-extent-for-new-child record child)
589      (when (eq record (output-record-parent child))
590        (let ((sheet (find-output-record-sheet record)))
591          (when sheet (note-output-record-got-sheet child sheet)))))
592    
593    (defmethod delete-output-record :before (child (record basic-output-record)
594                                             &optional (errorp t))
595      (declare (ignore errorp))
596      (let ((sheet (find-output-record-sheet record)))
597        (when sheet
598          (note-output-record-lost-sheet child sheet))))
599    
600    (defmethod delete-output-record (child (record basic-output-record)
601                                     &optional (errorp t))
602      (declare (ignore child))
603      (when errorp (error "Cannot delete a child from ~S." record)))
604    
605    (defmethod delete-output-record :after (child (record compound-output-record)
606                                                  &optional (errorp t))
607      (declare (ignore errorp))
608      (with-bounding-rectangle* (x1 y1 x2 y2) child
609        (recompute-extent-for-changed-child record child x1 y1 x2 y2)))
610    
611    (defmethod clear-output-record ((record basic-output-record))
612      (error "Cannot clear ~S." record))
613    
614    (defmethod clear-output-record :before ((record compound-output-record))
615      (let ((sheet (find-output-record-sheet record)))
616        (when sheet
617          (map-over-output-records #'note-output-record-lost-sheet record 0 0 sheet))))
618    
619    (defmethod clear-output-record :around ((record compound-output-record))
620      (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* record)
621        (call-next-method)
622        (assert (null-bounding-rectangle-p record))
623        (when (output-record-parent record)
624          (recompute-extent-for-changed-child
625           (output-record-parent record) record x1 y1 x2 y2))))
626    
627  (defmethod setf*-output-record-end-cursor-position (x y (record displayed-output-record))  (defmethod clear-output-record :after ((record compound-output-record))
628    (declare (ignore x y))    ;; XXX banish x and y
629      (with-slots (x y) record
630        (setf (rectangle-edges* record) (values x y x y))))
631    
632    (defmethod output-record-count ((record displayed-output-record))
633      0)
634    
635    (defmethod map-over-output-records-1
636        (function (record displayed-output-record) function-args)
637      (declare (ignore function function-args))
638    nil)    nil)
639    
640  (defun replay (record stream &optional region)  ;;; This needs to work in "most recently added last" order. Is this
641    (let ((old-record-p (gensym)))  ;;; implementation right? -- APD, 2002-06-13
642      `(let ((,old-record-p (stream-recording-p ,stream)))  #+nil
643         (when ,old-record-p  (defmethod map-over-output-records
644           (unwind-protect      (function (record compound-output-record)
645               (progn       &optional (x-offset 0) (y-offset 0)
646                 (setf (stream-recording-p ,stream) nil)       &rest function-args)
647                 (replay-output-record ,record ,stream ,region))    (declare (ignore x-offset y-offset))
648             (setf (stream-recording-p ,stream) ,old-record-p))))))    (map nil (lambda (child) (apply function child function-args))
649           (output-record-children record)))
 (defmethod replay-output-record ((record output-record) stream  
                                  &optional region x-offset y-offset)  
   (loop for child in (output-record-children record)  
         do (replay-output-record child stream region x-offset y-offset)))  
650    
651  (defmethod erase-output-record ((record output-record) stream)  (defmethod map-over-output-records-containing-position
652    (declare (ignore stream))      (function (record displayed-output-record) x y
653         &optional (x-offset 0) (y-offset 0)
654         &rest function-args)
655      (declare (ignore function x y x-offset y-offset function-args))
656    nil)    nil)
657    
658  (defmethod output-record-hit-detection-rectangle* ((record output-record))  ;;; This needs to work in "most recently added first" order. Is this
659    (bounding-rectangle* record))  ;;; implementation right? -- APD, 2002-06-13
660    #+nil
661    (defmethod map-over-output-records-containing-position
662        (function (record compound-output-record) x y
663         &optional (x-offset 0) (y-offset 0)
664         &rest function-args)
665      (declare (ignore x-offset y-offset))
666      (map nil
667           (lambda (child)
668             (when (and (multiple-value-bind (min-x min-y max-x max-y)
669                            (output-record-hit-detection-rectangle* child)
670                          (and (<= min-x x max-x) (<= min-y y max-y)))
671                        (output-record-refined-position-test child x y))
672               (apply function child function-args)))
673           (output-record-children record)))
674    
675    (defmethod map-over-output-records-overlapping-region
676        (function (record displayed-output-record) region
677         &optional (x-offset 0) (y-offset 0)
678         &rest function-args)
679      (declare (ignore function region x-offset y-offset function-args))
680      nil)
681    
682  (defmethod output-record-refined-sensitivity-test ((record output-record) x y)  ;;; This needs to work in "most recently added last" order. Is this
683    (region-contains-position-p (output-record-hit-detection-rectangle* record) x y))  ;;; implementation right? -- APD, 2002-06-13
684    #+nil
685    (defmethod map-over-output-records-overlapping-region
686        (function (record compound-output-record) region
687         &optional (x-offset 0) (y-offset 0)
688         &rest function-args)
689      (declare (ignore x-offset y-offset))
690      (map nil
691           (lambda (child) (when (region-intersects-region-p region child)
692                             (apply function child function-args)))
693           (output-record-children record)))
694    
695    ;;; XXX Dunno about this definition... -- moore
696    ;;; Your apprehension is justified, but we lack a better means by which
697    ;;; to distinguish "empty" compound records (roots of trees of compound
698    ;;; records, containing no non-compound records). Such subtrees should
699    ;;; not affect bounding rectangles.  -- Hefner
700    (defun null-bounding-rectangle-p (bbox)
701      (with-bounding-rectangle* (x1 y1 x2 y2) bbox
702         (and (= x1 x2)
703              (= y1 y2))))
704    
705    ;;; 16.2.3. Output Record Change Notification Protocol
706    (defmethod recompute-extent-for-new-child
707        ((record compound-output-record) child)
708      (unless (null-bounding-rectangle-p child)
709        (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2) record
710          (cond
711            ((null-bounding-rectangle-p record)
712             (setf (rectangle-edges* record) (bounding-rectangle* child)))
713            ((not (null-bounding-rectangle-p child))
714             (assert (not (null-bounding-rectangle-p record))) ; important.
715             (with-bounding-rectangle* (x1-child y1-child x2-child y2-child)
716                 child
717               (setf (rectangle-edges* record)
718                     (values (min old-x1 x1-child) (min old-y1 y1-child)
719                             (max old-x2 x2-child) (max old-y2 y2-child))))))
720          (let ((parent (output-record-parent record)))
721            (when parent
722              (recompute-extent-for-changed-child
723               parent record old-x1 old-y1 old-x2 old-y2)))))
724      record)
725    
726    (defmethod %tree-recompute-extent* ((record compound-output-record))
727      ;; Internal helper function
728      (let ((new-x1 0)
729            (new-y1 0)
730            (new-x2 0)
731            (new-y2 0)
732            (first-time t))
733        (map-over-output-records
734         (lambda (child)
735           (unless (null-bounding-rectangle-p child)
736             (if first-time
737                 (progn
738                   (multiple-value-setq (new-x1 new-y1 new-x2 new-y2)
739                     (bounding-rectangle* child))
740                   (setq first-time nil))
741                 (with-bounding-rectangle* (cx1 cy1 cx2 cy2) child
742                   (minf new-x1 cx1)
743                   (minf new-y1 cy1)
744                   (maxf new-x2 cx2)
745                   (maxf new-y2 cy2)))))
746         record)
747        (if first-time
748            ;; XXX banish x y
749            (with-slots (x y) record
750              (values x y x y))
751            (values new-x1 new-y1 new-x2 new-y2))))
752    
753  (defmethod highlight-output-record ((record output-record) stream state)  (defgeneric tree-recompute-extent-aux (record))
   (multiple-value-bind (x1 y1 x2 y2) (output-record-hit-detection-rectangle* record)  
     (ecase state  
       (:highlight  
        (draw-rectangle* stream x1 y1 x2 y2 :filled nil :ink +foreground-ink+))  
       (:unhighlight  
        (draw-rectangle* stream x1 y1 x2 y2 :filled nil :ink +background-ink+)))))  
754    
755  (defmethod add-output-record (child (record output-record))  (defmethod tree-recompute-extent-aux (record)
756    (with-slots (children) record    (bounding-rectangle* record))
757      (push child children))  
758    (with-slots (parent) child  (defmethod tree-recompute-extent-aux ((record compound-output-record))
759      (setf parent record)))    (let ((new-x1 0)
760            (new-y1 0)
761            (new-x2 0)
762            (new-y2 0)
763            (first-time t))
764        (map-over-output-records
765         (lambda (child)
766           (if first-time
767               (progn
768                 (multiple-value-setq (new-x1 new-y1 new-x2 new-y2)
769                   (tree-recompute-extent-aux child))
770                 (setq first-time nil))
771               (multiple-value-bind (cx1 cy1 cx2 cy2)
772                   (tree-recompute-extent-aux child)
773                 (minf new-x1 cx1)
774                 (minf new-y1 cy1)
775                 (maxf new-x2 cx2)
776                 (maxf new-y2 cy2))))
777         record)
778        (with-slots (x y)
779            record
780          (if first-time                    ;No children
781              (bounding-rectangle* record)
782              (progn
783                ;; XXX banish x,y
784                (setf  x new-x1 y new-y1)
785                (setf (rectangle-edges* record)
786                      (values new-x1 new-y1 new-x2 new-y2)))))))
787    
788    (defmethod recompute-extent-for-changed-child
789        ((record compound-output-record) changed-child
790         old-min-x old-min-y old-max-x old-max-y)
791      (with-bounding-rectangle* (ox1 oy1 ox2 oy2)  record
792        (with-bounding-rectangle* (cx1 cy1 cx2 cy2) changed-child
793          ;; If record is currently empty, use the child's bbox directly. Else..
794          ;; Does the new rectangle of the child contain the original rectangle?
795          ;; If so, we can use min/max to grow record's current rectangle.
796          ;; If not, the child has shrunk, and we need to fully recompute.
797          (multiple-value-bind (nx1 ny1 nx2 ny2)
798              (cond
799                ;; The child has been deleted; who knows what the
800                ;; new bounding box might be.
801                ;; This case shouldn't be really necessary.
802                ((not (output-record-parent changed-child))
803                 (%tree-recompute-extent* record))
804                ;; Only one child of record, and we already have the bounds.
805                ((eql (output-record-count record) 1)
806                 ;; See output-record-children for why this assert breaks:
807                 ;; (assert (eq changed-child (elt (output-record-children record) 0)))
808                 (values cx1 cy1 cx2 cy2))
809                ;; If our record occupied no space (had no children, or had only
810                ;; children similarly occupying no space, hackishly determined by
811                ;; null-bounding-rectangle-p), recompute the extent now, otherwise
812                ;; the next COND clause would, as an optimization, attempt to extend
813                ;; our current bounding rectangle, which is invalid.
814                ((null-bounding-rectangle-p record)
815                 (%tree-recompute-extent* record))
816                ;; In the following cases, we can grow the new bounding rectangle
817                ;; from its previous state:
818                ((or
819                  ;; If the child was originally empty, it could not have affected
820                  ;; previous computation of our bounding rectangle.
821                  ;; This is hackish for reasons similar to the above.
822                  (and (= old-min-x old-max-x) (= old-min-y old-max-y))
823                  ;; For each edge of the original child bounds, if it was within
824                  ;; its respective edge of the old parent bounding rectangle,
825                  ;; or if it has not changed:
826                  (and (or (> old-min-x ox1) (= old-min-x cx1))
827                       (or (> old-min-y oy1) (= old-min-y cy1))
828                       (or (< old-max-x ox2) (= old-max-x cx2))
829                       (or (< old-max-y oy2) (= old-max-y cy2)))
830                  ;; New child bounds contain old child bounds, so use min/max
831                  ;; to extend the already-calculated rectangle.
832                  (and (<= cx1 old-min-x) (<= cy1 old-min-y)
833                       (>= cx2 old-max-x) (>= cy2 old-max-y)))
834                 (values (min cx1 ox1) (min cy1 oy1)
835                         (max cx2 ox2) (max cy2 oy2)))
836                ;; No shortcuts - we must compute a new bounding box from those of
837                ;; all our children. We want to avoid this - in worst cases, such as
838                ;; a toplevel output history, large graph, or table, there may exist
839                ;; thousands of children. Without the above optimizations,
840                ;; construction becomes O(N^2) due to bounding rectangle calculation.
841                (t (%tree-recompute-extent* record)))
842            ;; XXX banish x, y
843            (with-slots (x y)
844                record
845              (setf x nx1 y ny1)
846              (setf (rectangle-edges* record) (values  nx1 ny1 nx2 ny2))
847              (let ((parent (output-record-parent record)))
848                (unless (or (null parent)
849                            (and (= nx1 ox1) (= ny1 oy1)
850                                 (= nx2 ox2) (= nx2 oy2)))
851                  (recompute-extent-for-changed-child parent record
852                                                      ox1 oy1 ox2 oy2)))))))
853      record)
854    
855    (defmethod tree-recompute-extent ((record compound-output-record))
856      (tree-recompute-extent-aux record)
857      record)
858    
859    (defmethod tree-recompute-extent :around ((record compound-output-record))
860      (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2)
861        record
862        (call-next-method)
863        (with-bounding-rectangle* (x1 y1 x2 y2)
864          record
865          (let ((parent (output-record-parent record)))
866            (when (and parent
867                       (not (and (= old-x1 x1)
868                                 (= old-y1 y1)
869                                 (= old-x2 x2)
870                                 (= old-y2 y2))))
871              (recompute-extent-for-changed-child parent record
872                                                  old-x1 old-y1
873                                                  old-x2 old-y2)))))
874      record)
875    
876    ;;; 16.3.1. Standard output record classes
877    
878    (defclass standard-sequence-output-record (compound-output-record)
879      ((children :initform (make-array 8 :adjustable t :fill-pointer 0)
880                 :reader output-record-children)))
881    
882    (defmethod add-output-record (child (record standard-sequence-output-record))
883      (vector-push-extend child (output-record-children record))
884      (setf (output-record-parent child) record))
885    
886  (defmethod delete-output-record (child (record output-record) &optional (errorp t))  (defmethod delete-output-record (child (record standard-sequence-output-record)
887                                     &optional (errorp t))
888    (with-slots (children) record    (with-slots (children) record
889      (if (and errorp      (let ((pos (position child children :test #'eq)))
890               (not (member child children)))        (if (null pos)
891          (error "~S is not a child of ~S" child record))            (when errorp
892      (setq children (delete child children))))              (error "~S is not a child of ~S" child record))
893            (progn
894  (defmethod clear-output-record ((record output-record))            (setq children (replace children children
895    (with-slots (children x-min y-min x-max y-max) record                                    :start1 pos
896      (setq children nil                                    :start2 (1+ pos)))
897            x-min 0            (decf (fill-pointer children))
898            y-min 0            (setf (output-record-parent child) nil))))))
899            x-max 0  
900            y-max 0)))  (defmethod clear-output-record ((record standard-sequence-output-record))
901      (let ((children (output-record-children record)))
902        (map 'nil (lambda (child) (setf (output-record-parent child) nil))
903             children)
904        (fill children nil)
905        (setf (fill-pointer children) 0)))
906    
907  (defmethod output-record-count ((record output-record))  (defmethod output-record-count ((record standard-sequence-output-record))
908    (length (output-record-children record)))    (length (output-record-children record)))
909    
910  (defmethod map-over-output-records-containing-position (function (record output-record) x y  (defmethod map-over-output-records-1
911                                                          &optional (x-offset 0) (y-offset 0))      (function (record standard-sequence-output-record) function-args)
912    (declare (dynamic-extent function)    "Applies FUNCTION to all children in the order they were added."
913             (ignore x-offset y-offset))    (if function-args
914    (loop for child in (output-record-children record)        (loop with children = (output-record-children record)
915          if (region-contains-position-p (output-record-hit-detection-rectangle* child) x y)           for child across children
916          do (funcall function child)))           do (apply function child function-args))
917          (loop with children = (output-record-children record)
918  (defmethod map-over-output-records-overlaping-region (function (record output-record) region           for child across children
919                                                        &optional (x-offset 0) (y-offset 0))           do (funcall function child))))
920    (declare (dynamic-extent function)  
921             (ignore x-offset y-offset))  (defmethod map-over-output-records-containing-position
922    (with-bounding-rectangle* (l1 t1 r1 b1) region      (function (record standard-sequence-output-record) x y
923      (loop for child in (output-record-children record)       &optional (x-offset 0) (y-offset 0)
924            do (with-bounding-rectangle* (l2 t2 r2 b2) child       &rest function-args)
925                 (if (and (<= l2 r1)    "Applies FUNCTION to children, containing (X,Y), in the reversed
926                          (>= r2 l1)  order they were added."
927                          (<= b2 t1)    (declare (ignore x-offset y-offset))
928                          (>= t2 b1))    (loop with children = (output-record-children record)
929                     (funcall function child))))))       for i from (1- (length children)) downto 0
930         for child = (aref children i)
931  (defmethod recompute-extent-for-new-child ((record output-record) child)       when (and (multiple-value-bind (min-x min-y max-x max-y)
932    (with-bounding-rectangle* (left top right bottom) record                     (output-record-hit-detection-rectangle* child)
933      (recompute-extent-for-changed-child record child left top right bottom)))                   (and (<= min-x x max-x) (<= min-y y max-y)))
934                   (output-record-refined-position-test child x y))
935  (defmethod recompute-extent-for-changed-child ((record output-record) child       do (apply function child function-args)))
936                                                 old-min-x old-min-y old-max-x old-max-y)  
937    (declare (ignore child old-min-x old-min-y old-max-x old-max-y))  (defmethod map-over-output-records-overlapping-region
938    (error "I don't understand RECOMPUTE-EXTENT-FOR-CHANGED-CHILD - mikemac"))      (function (record standard-sequence-output-record) region
939         &optional (x-offset 0) (y-offset 0)
940  (defmethod tree-recompute-extent ((record output-record))       &rest function-args)
941    (with-slots (parent children x-min y-min x-max y-max) record    "Applies FUNCTION to children, overlapping REGION, in the order they
942      (if (null children)  were added."
943          (setq x-min 0    (declare (ignore x-offset y-offset))
944                y-min 0    (loop with children = (output-record-children record)
945                x-max 0       for child across children
946                y-max 0)       when (region-intersects-region-p region child)
947        (with-bounding-rectangle* (left top right bottom) (first children)       do (apply function child function-args)))
948          (loop for child in (rest children)  
949                do (with-bounding-rectangle* (l1 t1 r1 b1) child  
950                     (setq left (min left l1 r1)  ;;; tree output recording
951                           top (min top t1 b1)  
952                           right (max right l1 r1)  (defclass tree-output-record-entry ()
953                           bottom (max bottom t1 b1))))       ((record :initarg :record :reader tree-output-record-entry-record)
954          (setq x-min left        (cached-rectangle :initform nil :accessor tree-output-record-entry-cached-rectangle)
955                y-min top        (inserted-nr :initarg :inserted-nr :accessor tree-output-record-entry-inserted-nr)))
956                x-max right  
957                y-max bottom)))  (defun make-tree-output-record-entry (record inserted-nr)
958      (if parent    (make-instance 'tree-output-record-entry :record record :inserted-nr inserted-nr))
959          (recompute-extent-for-changed-child parent record x-min y-min x-max y-max))))  
960    (defun %record-to-spatial-tree-rectangle (r)
961      (rectangles:make-rectangle
962       :lows `(,(bounding-rectangle-min-x r)
963                ,(bounding-rectangle-min-y r))
964       :highs `(,(bounding-rectangle-max-x r)
965                 ,(bounding-rectangle-max-y r))))
966    
967    (defun %output-record-entry-to-spatial-tree-rectangle (r)
968      (when (null (tree-output-record-entry-cached-rectangle r))
969        (let* ((record (tree-output-record-entry-record r)))
970          (setf (tree-output-record-entry-cached-rectangle r) (%record-to-spatial-tree-rectangle record))))
971      (tree-output-record-entry-cached-rectangle r))
972    
973    (defun %make-tree-output-record-tree ()
974      (spatial-trees:make-spatial-tree :r
975                            :rectfun #'%output-record-entry-to-spatial-tree-rectangle))
976    
977    (defclass standard-tree-output-record (compound-output-record)
978      ((children :initform (%make-tree-output-record-tree)
979                 :accessor %tree-record-children)
980       (children-hash :initform (make-hash-table :test #'eql) :reader %tree-record-children-cache)
981       (child-count :initform 0)
982       (last-insertion-nr :initform 0 :accessor last-insertion-nr)))
983    
984    (defun %entry-in-children-cache (record entry)
985      (gethash entry (%tree-record-children-cache record)))
986    
987    (defun (setf %entry-in-children-cache) (new-val record entry)
988      (setf (gethash entry (%tree-record-children-cache record)) new-val))
989    
990    (defun %remove-entry-from-children-cache (record entry)
991      (remhash entry (%tree-record-children-cache record)))
992    
993    (defmethod output-record-children ((record standard-tree-output-record))
994      (with-bounding-rectangle* (min-x min-y max-x max-y) record
995        (map 'list
996             #'tree-output-record-entry-record
997             (spatial-trees:search
998              ;; Originally, (%record-to-spatial-tree-rectangle record).
999              ;; The form below intends to fix output-record-children not
1000              ;; reporting empty children, which may lie outside the reported
1001              ;; bounding rectangle of their parent.
1002              ;; Assumption: null bounding records are always at the origin.
1003              ;; I've never noticed this violated, but it's out of line with
1004              ;; what null-bounding-rectangle-p checks, and setf of
1005              ;; output-record-position may invalidate it. Seems to work, but
1006              ;; fix that and try again later.
1007              ;; Note that max x or y may be less than zero..
1008              (rectangles:make-rectangle
1009               :lows  (list (min 0 min-x) (min 0 min-y))
1010               :highs (list (max 0 max-x) (max 0 max-y)))
1011              (%tree-record-children record)))))
1012    
1013    (defmethod add-output-record (child (record standard-tree-output-record))
1014      (let ((entry (make-tree-output-record-entry child (incf (last-insertion-nr record)))))
1015        (spatial-trees:insert entry (%tree-record-children record))
1016        (setf (output-record-parent child) record)
1017        (setf (%entry-in-children-cache record child) entry))
1018      (incf (slot-value record 'child-count))
1019      (values))
1020    
1021    (defmethod delete-output-record (child (record standard-tree-output-record) &optional (errorp t))
1022      (let ((entry (find child (spatial-trees:search (%entry-in-children-cache record child)
1023                                                     (%tree-record-children record))
1024                         :key #'tree-output-record-entry-record)))
1025        (decf (slot-value record 'child-count))
1026        (cond
1027          ((not (null entry))
1028           (spatial-trees:delete entry (%tree-record-children record))
1029           (%remove-entry-from-children-cache record child)
1030           (setf (output-record-parent child) nil))
1031          (errorp (error "~S is not a child of ~S" child record)))))
1032    
1033    (defmethod clear-output-record ((record standard-tree-output-record))
1034      (map nil (lambda (child)
1035                 (setf (output-record-parent child) nil)
1036                 (%remove-entry-from-children-cache record child))
1037           (output-record-children record))
1038      (setf (slot-value record 'child-count) 0)
1039      (setf (%tree-record-children record) (%make-tree-output-record-tree)))
1040    
1041    (defmethod output-record-count ((record standard-tree-output-record))
1042      (slot-value record 'child-count))
1043    
1044    (defun map-over-tree-output-records (function record rectangle sort-order function-args)
1045      (dolist (child (sort (spatial-trees:search rectangle
1046                                                 (%tree-record-children record))
1047                           (ecase sort-order
1048                             (:most-recent-first #'>)
1049                             (:most-recent-last #'<))
1050                           :key #'tree-output-record-entry-inserted-nr))
1051        (apply function (tree-output-record-entry-record child) function-args)))
1052    
1053    (defmethod map-over-output-records-1 (function (record standard-tree-output-record) function-args)
1054      (map-over-tree-output-records function record
1055        (%record-to-spatial-tree-rectangle record) :most-recent-last
1056                                    function-args))
1057    
1058    (defmethod map-over-output-records-containing-position
1059        (function (record standard-tree-output-record) x y
1060         &optional x-offset y-offset &rest function-args)
1061      (declare (ignore x-offset y-offset))
1062      (map-over-tree-output-records function record
1063        (rectangles:make-rectangle :lows `(,x ,y) :highs `(,x ,y)) :most-recent-first
1064                                    function-args))
1065    
1066    (defmethod map-over-output-records-overlapping-region
1067        (function (record standard-tree-output-record) region
1068         &optional x-offset y-offset &rest function-args)
1069      (declare (ignore x-offset y-offset))
1070      (typecase region
1071        (everywhere-region (map-over-output-records-1 function record function-args))
1072        (nowhere-region nil)
1073        (otherwise (map-over-tree-output-records
1074                    (lambda (child)
1075                      (if (region-intersects-region-p (multiple-value-call 'make-rectangle* (bounding-rectangle* child))
1076                                                         region)
1077                           (apply function child function-args)))
1078                    record (%record-to-spatial-tree-rectangle (bounding-rectangle region)) :most-recent-last
1079                    nil))))
1080    
1081    (defmethod recompute-extent-for-changed-child :around ((record standard-tree-output-record) child old-min-x old-min-y old-max-x old-max-y)
1082      (when (eql record (output-record-parent child))
1083        (let ((entry (%entry-in-children-cache record child)))
1084         (spatial-trees:delete entry (%tree-record-children record))
1085         (setf (tree-output-record-entry-cached-rectangle entry) nil)
1086         (spatial-trees:insert entry (%tree-record-children record))))
1087      (call-next-method))
1088    
1089  (defclass standard-sequence-output-record (displayed-output-record)  ;;;
   (  
    ))  
   
 (defclass standard-tree-output-record (displayed-output-record)  
   (  
    ))  
1090    
1091    (defmethod match-output-records ((record t) &rest args)
1092  ;;; Graphics recording classes    (apply #'match-output-records-1 record args))
1093    
1094  (defclass graphics-displayed-output-record (displayed-output-record)  ;;; Factor out the graphics state portions of the output records so
1095    ((ink :initarg :ink)  ;;; they can be manipulated seperately e.g., by incremental
1096     (clip :initarg :clipping-region)  ;;; display. The individual slots of a graphics state are factored into mixin
1097     (transform :initarg :transformation)  ;;; classes so that each output record can capture only the state that it needs.
1098     (line-style :initarg :line-style)  ;;; -- moore
1099     (text-style :initarg :text-style)  
1100     ))  ;;; It would be appealing to define a setf method, e.g. (setf
1101    ;;; medium-graphics-state), for setting a medium's state from a graphics state
1102    ;;; object, but that would require us to define a medium-graphics-state reader
1103    ;;; that would cons a state object.  I don't want to do that.
1104    
1105    (defclass graphics-state ()
1106      ()
1107      (:documentation "Stores those parts of the medium/stream graphics state
1108      that need to be restored when drawing an output record"))
1109    
1110    (defclass gs-ink-mixin (graphics-state)
1111      ((ink :initarg :ink :accessor graphics-state-ink)))
1112    
1113    (defmethod initialize-instance :after ((obj gs-ink-mixin)
1114                                           &key (stream nil)
1115                                           (medium (when stream
1116                                                     (sheet-medium stream))))
1117      (when (and medium (not (slot-boundp obj 'ink)))
1118        (setf (slot-value obj 'ink) (medium-ink medium))))
1119    
1120    (defmethod replay-output-record :around
1121        ((record gs-ink-mixin) stream &optional region x-offset y-offset)
1122      (declare (ignore region x-offset y-offset))
1123      (with-drawing-options (stream :ink (graphics-state-ink record))
1124        (call-next-method)))
1125    
1126  (defun graphics-displayed-output-record-p (x)  (defrecord-predicate gs-ink-mixin (ink)
1127    (typep x 'graphics-displayed-output-record))    (if-supplied (ink)
1128        (design-equalp (slot-value record 'ink) ink)))
1129    
1130    (defclass gs-clip-mixin (graphics-state)
1131      ((clip :initarg :clipping-region :accessor graphics-state-clip
1132             :documentation "Clipping region in stream coordinates.")))
1133    
1134    (defmethod initialize-instance :after ((obj gs-clip-mixin)
1135                                           &key (stream nil)
1136                                           (medium (when stream
1137                                                     (sheet-medium stream))))
1138      (when medium
1139        (with-slots (clip)
1140            obj
1141          (let ((clip-region (if (slot-boundp obj 'clip)
1142                                 (region-intersection (medium-clipping-region
1143                                                       medium)
1144                                                      clip)
1145                                 (medium-clipping-region medium))))
1146            (setq clip (transform-region (medium-transformation medium)
1147                                         clip-region))))))
1148    
1149    (defmethod replay-output-record :around
1150        ((record gs-clip-mixin) stream &optional region x-offset y-offset)
1151      (declare (ignore region x-offset y-offset))
1152      (let ((clipping-region (graphics-state-clip record)))
1153        (if (or (eq clipping-region +everywhere+) ; !!!
1154                (region-contains-region-p clipping-region (medium-clipping-region stream)))
1155            (call-next-method)
1156            (with-drawing-options (stream :clipping-region (graphics-state-clip record))
1157              (call-next-method)))))
1158    
1159    (defrecord-predicate gs-clip-mixin ((:clipping-region clip))
1160      (if-supplied (clip)
1161        (region-equal (slot-value record 'clip) clip)))
1162    
1163    ;;; 16.3.2. Graphics Displayed Output Records
1164    (defclass standard-displayed-output-record (gs-clip-mixin gs-ink-mixin
1165                                                basic-output-record
1166                                                displayed-output-record)
1167      ((ink :reader displayed-output-record-ink)
1168       (stream :initarg :stream))
1169      (:documentation "Implementation class for DISPLAYED-OUTPUT-RECORD.")
1170      (:default-initargs :stream nil))
1171    
1172    (defclass gs-line-style-mixin (graphics-state)
1173      ((line-style :initarg :line-style :accessor graphics-state-line-style)))
1174    
1175    (defmethod initialize-instance :after ((obj gs-line-style-mixin)
1176                                           &key (stream nil)
1177                                           (medium (when stream
1178                                                     (sheet-medium stream))))
1179      (when medium
1180        (unless (slot-boundp obj 'line-style)
1181          (setf (slot-value obj 'line-style) (medium-line-style medium)))))
1182    
1183    (defmethod replay-output-record :around
1184        ((record gs-line-style-mixin) stream &optional region x-offset y-offset)
1185      (declare (ignore region x-offset y-offset))
1186      (with-drawing-options (stream :line-style (graphics-state-line-style record))
1187        (call-next-method)))
1188    
1189    (defrecord-predicate gs-line-style-mixin (line-style)
1190  ;;; stream-output-history-mixin class    (if-supplied (line-style)
1191        (line-style-equalp (slot-value record 'line-style) line-style)))
1192    
1193    (defgeneric graphics-state-line-style-border (record medium)
1194      (:method ((record gs-line-style-mixin) medium)
1195        (/ (line-style-effective-thickness (graphics-state-line-style record)
1196                                            medium)
1197           2)))
1198    
1199    (defclass gs-text-style-mixin (graphics-state)
1200      ((text-style :initarg :text-style :accessor graphics-state-text-style)))
1201    
1202    (defmethod initialize-instance :after ((obj gs-text-style-mixin)
1203                                           &key (stream nil)
1204                                           (medium (when stream
1205                                                     (sheet-medium stream))))
1206      (when medium
1207        (unless (slot-boundp obj 'text-style)
1208          (setf (slot-value obj 'text-style) (medium-text-style medium)))))
1209    
1210    (defmethod replay-output-record :around
1211        ((record gs-text-style-mixin) stream &optional region x-offset y-offset)
1212      (declare (ignore region x-offset y-offset))
1213      (with-drawing-options (stream :text-style (graphics-state-text-style record))
1214        (call-next-method)))
1215    
1216  (defclass stream-output-history-mixin ()  (defrecord-predicate gs-text-style-mixin (text-style)
1217    ((output-history :initform (make-instance 'standard-sequence-output-record)    (if-supplied (text-style)
1218                     :reader stream-output-history)      (text-style-equalp (slot-value record 'text-style) text-style)))
1219     (recording-p :initform t  
1220                  :accessor stream-recording-p)  (defclass standard-graphics-displayed-output-record
1221     (drawing-p :initform t      (standard-displayed-output-record
1222                :accessor stream-drawing-p)       graphics-displayed-output-record)
1223     ))    ())
1224    
1225    (defmethod match-output-records-1 and
1226      ((record standard-displayed-output-record)
1227       &key (x1 nil x1-p) (y1 nil y1-p)
1228       (x2 nil x2-p) (y2 nil y2-p)
1229       (bounding-rectangle nil bounding-rectangle-p))
1230      (if bounding-rectangle-p
1231          (region-equal record bounding-rectangle)
1232          (multiple-value-bind (my-x1 my-y1 my-x2 my-y2)
1233              (bounding-rectangle* record)
1234            (macrolet ((coordinate=-or-lose (key mine)
1235                         `(if (typep ,key 'coordinate)
1236                              (coordinate= ,mine ,key)
1237                              (error 'type-error
1238                                     :datum ,key
1239                                     :expected-type 'coordinate))))
1240              (and (or (null x1-p)
1241                       (coordinate=-or-lose x1 my-x1))
1242                   (or (null y1-p)
1243                       (coordinate=-or-lose y1 my-y1))
1244                   (or (null x2-p)
1245                       (coordinate=-or-lose x2 my-x2))
1246                   (or (null y2-p)
1247                       (coordinate=-or-lose y2 my-y2)))))))
1248    
1249    (defmethod output-record-equal and ((record standard-displayed-output-record)
1250                                        (record2 standard-displayed-output-record))
1251      (region-equal record record2))
1252    
1253    (defclass coord-seq-mixin ()
1254      ((coord-seq :accessor coord-seq :initarg :coord-seq))
1255      (:documentation "Mixin class that implements methods for records that contain
1256       sequences of coordinates."))
1257    
1258    (defun coord-seq-bounds (coord-seq border)
1259      (setf border (ceiling border))
1260      (let* ((min-x (elt coord-seq 0))
1261             (min-y (elt coord-seq 1))
1262             (max-x min-x)
1263             (max-y min-y))
1264        (do-sequence ((x y) coord-seq)
1265          (minf min-x x)
1266          (minf min-y y)
1267          (maxf max-x x)
1268          (maxf max-y y))
1269        (values (floor (- min-x border))
1270                (floor (- min-y border))
1271                (ceiling (+ max-x border))
1272                (ceiling (+ max-y border)))))
1273    
1274    ;;; record must be a standard-rectangle
1275    
1276    (defmethod* (setf output-record-position) :around
1277        (nx ny (record coord-seq-mixin))
1278      (with-standard-rectangle* (:x1 x1 :y1 y1)
1279          record
1280        (let ((dx (- nx x1))
1281              (dy (- ny y1))
1282              (coords (slot-value record 'coord-seq)))
1283          (multiple-value-prog1
1284              (call-next-method)
1285            (loop for i from 0 below (length coords) by 2
1286                  do (progn
1287                       (incf (aref coords i) dx)
1288                       (incf (aref coords (1+ i)) dy)))))))
1289    
1290    (defmethod match-output-records-1 and ((record coord-seq-mixin)
1291                                           &key (coord-seq nil coord-seq-p))
1292      (or (null coord-seq-p)
1293          (let* ((my-coord-seq (slot-value record 'coord-seq))
1294                 (len (length my-coord-seq)))
1295            (and (eql len (length coord-seq))
1296                 (loop for elt1 across my-coord-seq
1297                       for elt2 across coord-seq
1298                       always (coordinate= elt1 elt2))))))
1299    
1300    (defmacro generate-medium-recording-body (class-name method-name args)
1301      (let ((arg-list (loop for arg in args
1302                         nconc `(,(intern (symbol-name arg) :keyword) ,arg))))
1303        `(with-sheet-medium (medium stream)
1304                      (when (stream-recording-p stream)
1305                        (let ((record
1306                               ;; Hack: the coord-seq-mixin makes the assumption that, well
1307                               ;; coord-seq is a coord-vector. So we morph a possible
1308                               ;; coord-seq argument into a vector.
1309                               (let (,@(when (member 'coord-seq args)
1310                                             `((coord-seq
1311                                                (if (vectorp coord-seq)
1312                                                    coord-seq
1313                                                    (coerce coord-seq 'vector))))))
1314                                 (make-instance ',class-name
1315                                                :stream stream
1316                                                ,@arg-list))))
1317                          (stream-add-output-record stream record)))
1318                      (when (stream-drawing-p stream)
1319                        (,method-name medium ,@args)))))
1320    
1321    ;; DEF-GRECORDING: This is the central interface through which recording
1322    ;; is implemented for drawing functions. The body provided is used to
1323    ;; compute the bounding rectangle of the rendered output. DEF-GRECORDING
1324    ;; will define a class for the output record, with slots corresponding to the
1325    ;; drawing function arguments. It also defines an INITIALIZE-INSTANCE method
1326    ;; computing the bounding rectangle of the record. It defines a method for
1327    ;; the medium drawing function specialized on output-recording-stream, which
1328    ;; is responsible for creating the output record and adding it to the stream
1329    ;; history. It also defines a REPLAY-OUTPUT-RECORD method, which calls the
1330    ;; medium drawing function based on the recorded slots.
1331    
1332    (defmacro def-grecording (name ((&rest mixins) &rest args)
1333                                   (&key (class t)
1334                                         (medium-fn t)
1335                                         (replay-fn t)) &body body)
1336      (let ((method-name (symbol-concat '#:medium- name '*))
1337            (class-name (symbol-concat name '#:-output-record))
1338            (medium (gensym "MEDIUM"))
1339            (class-vars `((stream :initarg :stream)
1340                          ,@(loop for arg in args
1341                               collect `(,arg
1342                                         :initarg ,(intern (symbol-name arg)
1343                                                           :keyword))))))
1344        `(progn
1345          ,@(when class
1346                  `((defclass ,class-name (,@mixins standard-graphics-displayed-output-record)
1347                      ,class-vars)
1348                    (defmethod initialize-instance :after ((graphic ,class-name)
1349                                                           &key)
1350                      (with-slots (stream ink clipping-region
1351                                   line-style text-style ,@args)
1352                          graphic
1353                        (let* ((medium (sheet-medium stream)))
1354                          (setf (rectangle-edges* graphic)
1355                                (progn ,@body)))))))
1356          ,(when medium-fn
1357                 `(defmethod ,method-name :around ((stream output-recording-stream) ,@args)
1358                    ;; XXX STANDARD-OUTPUT-RECORDING-STREAM ^?
1359                   (generate-medium-recording-body ,class-name ,method-name ,args)))
1360          ,(when replay-fn
1361                 `(defmethod replay-output-record ((record ,class-name) stream
1362                                                   &optional (region +everywhere+)
1363                                                   (x-offset 0) (y-offset 0))
1364                   (declare (ignore x-offset y-offset region))
1365                   (with-slots (,@args) record
1366                     (let ((,medium (sheet-medium stream))
1367                           ;; is sheet a sheet-with-medium-mixin? --GB
1368                           )
1369                       ;; Graphics state is set up in :around method.
1370                       (,method-name ,medium ,@args))))))))
1371    
1372    (def-grecording draw-point ((gs-line-style-mixin) point-x point-y) ()
1373      (let ((border (graphics-state-line-style-border graphic medium)))
1374        (with-transformed-position ((medium-transformation medium) point-x point-y)
1375          (setf (slot-value graphic 'point-x) point-x
1376                (slot-value graphic 'point-y) point-y)
1377          (values (- point-x border)
1378                  (- point-y border)
1379                  (+ point-x border)
1380                  (+ point-y border)))))
1381    
1382    (defmethod* (setf output-record-position) :around
1383        (nx ny (record draw-point-output-record))
1384        (with-standard-rectangle* (:x1 x1 :y1 y1)
1385            record
1386          (with-slots (point-x point-y)
1387              record
1388            (let ((dx (- nx x1))
1389                  (dy (- ny y1)))
1390              (multiple-value-prog1
1391                  (call-next-method)
1392                (incf point-x dx)
1393                (incf point-y dy))))))
1394    
1395    (defrecord-predicate draw-point-output-record (point-x point-y)
1396      (and (if-supplied (point-x coordinate)
1397             (coordinate= (slot-value record 'point-x) point-x))
1398           (if-supplied (point-y coordinate)
1399             (coordinate= (slot-value record 'point-y) point-y))))
1400    
1401    (def-grecording draw-points ((coord-seq-mixin gs-line-style-mixin) coord-seq) ()
1402      (let ((transformed-coord-seq (transform-positions (medium-transformation medium) coord-seq))
1403            (border (graphics-state-line-style-border graphic medium)))
1404        (setf (slot-value graphic 'coord-seq) transformed-coord-seq)
1405        (coord-seq-bounds transformed-coord-seq border)))
1406    
1407    (def-grecording draw-line ((gs-line-style-mixin)
1408                               point-x1 point-y1 point-x2 point-y2) ()
1409      (let ((transform (medium-transformation medium))
1410            (border (graphics-state-line-style-border graphic medium)))
1411        (with-transformed-position (transform point-x1 point-y1)
1412          (with-transformed-position (transform point-x2 point-y2)
1413            (setf (slot-value graphic 'point-x1) point-x1
1414                  (slot-value graphic 'point-y1) point-y1
1415                  (slot-value graphic 'point-x2) point-x2
1416                  (slot-value graphic 'point-y2) point-y2)
1417            (values (- (min point-x1 point-x2) border)
1418                    (- (min point-y1 point-y2) border)
1419                    (+ (max point-x1 point-x2) border)
1420                    (+ (max point-y1 point-y2) border))))))
1421    
1422    (defmethod* (setf output-record-position) :around
1423        (nx ny (record draw-line-output-record))
1424      (with-standard-rectangle* (:x1 x1 :y1 y1)
1425          record
1426        (with-slots (point-x1 point-y1 point-x2 point-y2)
1427            record
1428          (let ((dx (- nx x1))
1429                (dy (- ny y1)))
1430            (multiple-value-prog1
1431                (call-next-method)
1432              (incf point-x1 dx)
1433              (incf point-y1 dy)
1434              (incf point-x2 dx)
1435              (incf point-y2 dy))))))
1436    
1437    (defrecord-predicate draw-line-output-record (point-x1 point-y1
1438                                                  point-x2 point-y2)
1439      (and (if-supplied (point-x1 coordinate)
1440             (coordinate= (slot-value record 'point-x1) point-x1))
1441           (if-supplied (point-y1 coordinate)
1442             (coordinate= (slot-value record 'point-y1) point-y1))
1443           (if-supplied (point-x2 coordinate)
1444             (coordinate= (slot-value record 'point-x2) point-x2))
1445           (if-supplied (point-y2 coordinate)
1446             (coordinate= (slot-value record 'point-y2) point-y2))))
1447    
1448    (def-grecording draw-lines ((coord-seq-mixin gs-line-style-mixin) coord-seq) ()
1449      (let ((transformed-coord-seq (transform-positions (medium-transformation medium) coord-seq))
1450            (border (graphics-state-line-style-border graphic medium)))
1451        (setf coord-seq transformed-coord-seq)
1452        (coord-seq-bounds transformed-coord-seq border)))
1453    
1454    ;;; (setf output-record-position) and predicates for draw-lines-output-record
1455    ;;; are taken care of by methods on superclasses.
1456    
1457    ;;; Helper function
1458    (defun normalize-coords (dx dy &optional unit)
1459      (let ((norm (sqrt (+ (* dx dx) (* dy dy)))))
1460        (cond ((= norm 0.0d0)
1461               (values 0.0d0 0.0d0))
1462              (unit
1463               (let ((scale (/ unit norm)))
1464                 (values (* dx scale) (* dy scale))))
1465              (t (values (/ dx norm) (/ dy norm))))))
1466    
1467    (defun polygon-record-bounding-rectangle
1468        (coord-seq closed filled line-style border miter-limit)
1469      (cond (filled
1470             (coord-seq-bounds coord-seq 0))
1471            ((eq (line-style-joint-shape line-style) :round)
1472             (coord-seq-bounds coord-seq border))
1473            (t (let* ((x1 (svref coord-seq 0))
1474                      (y1 (svref coord-seq 1))
1475                      (min-x x1)
1476                      (min-y y1)
1477                      (max-x x1)
1478                      (max-y y1)
1479                      (len (length coord-seq)))
1480                 (unless closed
1481                   (setq min-x (- x1 border)  min-y (- y1 border)
1482                         max-x (+ x1 border)  max-y (+ y1 border)))
1483                 ;; Setup for iterating over the coordinate vector.  If the polygon
1484                 ;; is closed deal with the extra segment.
1485                 (multiple-value-bind (initial-xp initial-yp
1486                                       final-xn final-yn
1487                                       initial-index final-index)
1488                     (if closed
1489                         (values (svref coord-seq (- len 2))
1490                                 (svref coord-seq (- len 1))
1491                                 x1 y1
1492                                 0 (- len 2))
1493                         (values x1 y1
1494                                 (svref coord-seq (- len 2))
1495                                 (svref coord-seq (- len 1))
1496                                 2 (- len 4)))
1497                   (ecase (line-style-joint-shape line-style)
1498                     (:miter
1499                      ;;FIXME: Remove successive positively proportional segments
1500                      (loop with sin-limit = (sin (* 0.5 miter-limit))
1501                            and xn and yn
1502                            for i from initial-index to final-index by 2
1503                            for xp = initial-xp then x
1504                            for yp = initial-yp then y
1505                            for x = (svref coord-seq i)
1506                            for y = (svref coord-seq (1+ i))
1507                            do (setf (values xn yn)
1508                                     (if (eql i final-index)
1509                                         (values final-xn final-yn)
1510                                         (values (svref coord-seq (+ i 2))
1511                                                 (svref coord-seq (+ i 3)))))
1512                               (multiple-value-bind (ex1 ey1)
1513                                   (normalize-coords (- x xp) (- y yp))
1514                                 (multiple-value-bind (ex2 ey2)
1515                                     (normalize-coords (- x xn) (- y yn))
1516                                   (let* ((cos-a (+ (* ex1 ex2) (* ey1 ey2)))
1517                                          (sin-a/2 (sqrt (* 0.5 (- 1.0 cos-a)))))
1518                                     (if (< sin-a/2 sin-limit)
1519                                         (let ((nx (* border
1520                                                      (max (abs ey1) (abs ey2))))
1521                                               (ny (* border
1522                                                      (max (abs ex1) (abs ex2)))))
1523                                           (minf min-x (- x nx))
1524                                           (minf min-y (- y ny))
1525                                           (maxf max-x (+ x nx))
1526                                           (maxf max-y (+ y ny)))
1527                                         (let ((length (/ border sin-a/2)))
1528                                           (multiple-value-bind (dx dy)
1529                                               (normalize-coords (+ ex1 ex2)
1530                                                                 (+ ey1 ey2)
1531                                                                 length)
1532                                             (minf min-x (+ x dx))
1533                                             (minf min-y (+ y dy))
1534                                             (maxf max-x (+ x dx))
1535                                             (maxf max-y (+ y dy))))))))))
1536                     ((:bevel :none)
1537                      (loop with xn and yn
1538                            for i from initial-index to final-index by 2
1539                            for xp = initial-xp then x
1540                            for yp = initial-yp then y
1541                            for x = (svref coord-seq i)
1542                            for y = (svref coord-seq (1+ i))
1543                            do (setf (values xn yn)
1544                                     (if (eql i final-index)
1545                                         (values final-xn final-yn)
1546                                         (values (svref coord-seq (+ i 2))
1547                                                 (svref coord-seq (+ i
1548                                                                     3)))))
1549                               (multiple-value-bind (ex1 ey1)
1550                                   (normalize-coords (- x xp) (- y yp))
1551                                 (multiple-value-bind (ex2 ey2)
1552                                     (normalize-coords (- x xn) (- y yn))
1553                                   (let ((nx (* border (max (abs ey1) (abs ey2))))
1554                                         (ny (* border (max (abs ex1) (abs ex2)))))
1555                                     (minf min-x (- x nx))
1556                                     (minf min-y (- y ny))
1557                                     (maxf max-x (+ x nx))
1558                                     (maxf max-y (+ y ny))))))))
1559                   (unless closed
1560                     (multiple-value-bind (x y)
1561                         (values (svref coord-seq (- len 2))
1562                                 (svref coord-seq (- len 1)))
1563                       (minf min-x (- x border))
1564                       (minf min-y (- y border))
1565                       (maxf max-x (+ x border))
1566                       (maxf max-y (+ y border)))))
1567                 (values min-x min-y max-x max-y)))))
1568    
1569    (def-grecording draw-polygon ((coord-seq-mixin gs-line-style-mixin)
1570                                  coord-seq closed filled) ()
1571      (let ((transformed-coord-seq (transform-positions (medium-transformation medium) coord-seq))
1572            (border (graphics-state-line-style-border graphic medium)))
1573        (setf coord-seq transformed-coord-seq)
1574        (polygon-record-bounding-rectangle transformed-coord-seq
1575                                           closed filled line-style border
1576                                           (medium-miter-limit medium))))
1577    
1578    (defrecord-predicate draw-polygon-output-record (closed filled)
1579      (and (if-supplied (closed)
1580             (eql (slot-value record 'closed) closed))
1581           (if-supplied (filled)
1582             (eql (slot-value record 'filled) filled))))
1583    
1584    (def-grecording draw-rectangle ((gs-line-style-mixin)
1585                                    left top right bottom filled) (:medium-fn nil)
1586      (let* ((transform (medium-transformation medium))
1587             (border     (graphics-state-line-style-border graphic medium))
1588             (pre-coords (expand-rectangle-coords left top right bottom))
1589             (coords     (transform-positions transform pre-coords)))
1590        (setf (values left top) (transform-position transform left top))
1591        (setf (values right bottom) (transform-position transform right bottom))
1592        (polygon-record-bounding-rectangle coords t filled line-style border
1593                                           (medium-miter-limit medium))))
1594    
1595    (defmethod medium-draw-rectangle* :around ((stream output-recording-stream) left top right bottom filled)
1596      (let ((tr (medium-transformation stream)))
1597        (if (rectilinear-transformation-p tr)
1598            (generate-medium-recording-body draw-rectangle-output-record
1599                                            medium-draw-rectangle*
1600                                            (left top right bottom filled))
1601            (medium-draw-polygon* stream
1602                                  (expand-rectangle-coords left top right bottom)
1603                                  t
1604                                  filled))))
1605    
1606    (defmethod* (setf output-record-position) :around
1607        (nx ny (record draw-rectangle-output-record))
1608      (with-standard-rectangle* (:x1 x1 :y1 y1)
1609          record
1610        (with-slots (left top right bottom)
1611            record
1612          (let ((dx (- nx x1))
1613                (dy (- ny y1)))
1614            (multiple-value-prog1
1615                (call-next-method)
1616              (incf left dx)
1617              (incf top dy)
1618              (incf right dx)
1619              (incf bottom dy))))))
1620    
1621    (defrecord-predicate draw-rectangle-output-record (left top right bottom filled)
1622      (and (if-supplied (left coordinate)
1623             (coordinate= (slot-value record 'left) left))
1624           (if-supplied (top coordinate)
1625             (coordinate= (slot-value record 'top) top))
1626           (if-supplied (right coordinate)
1627             (coordinate= (slot-value record 'right) right))
1628           (if-supplied (bottom coordinate)
1629             (coordinate= (slot-value record 'bottom) bottom))
1630           (if-supplied (filled)
1631             (eql (slot-value record 'filled) filled))))
1632    
1633  (defmethod scroll-vertical :around ((stream stream-output-history-mixin) dy)  (def-grecording draw-ellipse ((gs-line-style-mixin)
1634    (declare (ignore dy))                                center-x center-y
1635    (with-output-recording-options (stream :record nil)                                radius-1-dx radius-1-dy radius-2-dx radius-2-dy
1636      (call-next-method)))                                start-angle end-angle filled) ()
1637      (let ((transform (medium-transformation medium)))
1638        (setf (values center-x center-y)
1639              (transform-position transform center-x center-y))
1640        (setf (values radius-1-dx radius-1-dy)
1641              (transform-distance transform radius-1-dx radius-1-dy))
1642        (setf (values radius-2-dx radius-2-dy)
1643              (transform-distance transform radius-2-dx radius-2-dy))
1644        ;; I think this should be untransform-angle below, as the ellipse angles
1645        ;; go counter-clockwise in screen coordinates, whereas our transformations
1646        ;; rotate clockwise in the default coorinate system.. this is quite possibly
1647        ;; wrong depending on how one reads the spec, but just reversing it here
1648        ;; will break other things.  -Hefner
1649        (setf start-angle (untransform-angle transform start-angle))
1650        (setf end-angle   (untransform-angle transform end-angle))
1651        (when (reflection-transformation-p transform)
1652          (rotatef start-angle end-angle))
1653        (multiple-value-bind (min-x min-y max-x max-y)
1654            (bounding-rectangle* (make-ellipse* center-x center-y
1655                                                radius-1-dx radius-1-dy
1656                                                radius-2-dx radius-2-dy
1657                                                :start-angle start-angle
1658                                                :end-angle end-angle))
1659          (if filled
1660              (values min-x min-y max-x max-y)
1661              (let ((border (graphics-state-line-style-border graphic medium)))
1662                (values (- min-x border)
1663                        (- min-y border)
1664                        (+ max-x border)
1665                        (+ max-y border)))))))
1666    
1667    (defmethod* (setf output-record-position) :around
1668        (nx ny (record draw-ellipse-output-record))
1669      (with-standard-rectangle* (:x1 x1 :y1 y1)
1670          record
1671        (with-slots (center-x center-y)
1672            record
1673          (let ((dx (- nx x1))
1674                (dy (- ny y1)))
1675            (multiple-value-prog1
1676                (call-next-method)
1677              (incf center-x dx)
1678              (incf center-y dy))))))
1679    
1680    (defrecord-predicate draw-ellipse-output-record (center-x center-y)
1681      (and (if-supplied (center-x coordinate)
1682             (coordinate= (slot-value record 'center-x) center-x))
1683           (if-supplied (center-y coordinate)
1684             (coordinate= (slot-value record 'center-y) center-y))))
1685    
1686    ;;;; Patterns
1687    
1688    ;;; The Spec says that "transformation only affects the position at
1689    ;;; which the pattern is drawn, not the pattern itself"
1690    (def-grecording draw-pattern (() pattern x y) ()
1691      (let ((width (pattern-width pattern))
1692            (height (pattern-height pattern))
1693            (transform (medium-transformation medium)))
1694        (setf (values x y) (transform-position transform x y))
1695        (values x y (+ x width) (+ y height))))
1696    
1697    (defmethod* (setf output-record-position) :around
1698        (nx ny (record draw-pattern-output-record))
1699    (with-standard-rectangle* (:x1 x1 :y1 y1)
1700        record
1701      (with-slots (x y)
1702          record
1703        (let ((dx (- nx x1))
1704              (dy (- ny y1)))
1705          (multiple-value-prog1
1706              (call-next-method)
1707            (incf x dx)
1708            (incf y dy))))))
1709    
1710    (defrecord-predicate draw-pattern-output-record (x y pattern)
1711      ;; ### I am not so sure about the correct usage of DEFRECORD-PREDICATE
1712      ;; --GB 2003-08-15
1713      (and (if-supplied (x coordinate)
1714             (coordinate= (slot-value record 'x) x))
1715           (if-supplied (y coordinate)
1716             (coordinate= (slot-value record 'y) y))
1717           (if-supplied (pattern pattern)
1718             (eq (slot-value record 'pattern) pattern))))
1719    
1720    ;;;; RGB images
1721    
1722    (def-grecording draw-image-design (() image-design x y) ()
1723      (let ((width (image-width (image image-design)))
1724            (height (image-height (image image-design)))
1725            (transform (medium-transformation medium)))
1726        (setf (values x y) (transform-position transform x y))
1727        (values x y (+ x width) (+ y height))))
1728    
1729    (defmethod* (setf output-record-position) :around
1730                (nx ny (record draw-image-design-output-record))
1731      (with-standard-rectangle* (:x1 x1 :y1 y1) record
1732        (with-slots (x y) record
1733          (let ((dx (- nx x1))
1734                (dy (- ny y1)))
1735            (multiple-value-prog1 (call-next-method)
1736              (incf x dx)
1737              (incf y dy))))))
1738    
1739    (defrecord-predicate draw-image-design-output-record (x y image-design)
1740      (and (if-supplied (x coordinate)
1741             (coordinate= (slot-value record 'x) x))
1742           (if-supplied (y coordinate)
1743             (coordinate= (slot-value record 'y) y))
1744           (if-supplied (image-design rgb-image-design)
1745             (eq (slot-value record 'image-design) image-design))))
1746    
1747    ;;;; Text
1748    
1749    (def-grecording draw-text ((gs-text-style-mixin) string point-x point-y start end
1750                               align-x align-y toward-x toward-y transform-glyphs) ()
1751      ;; FIXME!!! Text direction.
1752      ;; FIXME: Multiple lines.
1753     (let* ((text-style (graphics-state-text-style graphic))
1754            (width (if (characterp string)
1755                       (stream-character-width stream string :text-style text-style)
1756                       (stream-string-width stream string
1757                                            :start start :end end
1758                                            :text-style text-style)) )
1759            (ascent (text-style-ascent text-style (sheet-medium stream)))
1760            (descent (text-style-descent text-style (sheet-medium stream)))
1761            (transform (medium-transformation medium)))
1762       (setf (values point-x point-y)
1763             (transform-position transform point-x point-y))
1764       (multiple-value-bind (left top right bottom)
1765           (text-bounding-rectangle* medium string
1766                                     :start start :end end :text-style text-style)
1767         (ecase align-x
1768           (:left (incf left point-x) (incf right point-x))
1769           (:right (incf left (- point-x width)) (incf right (- point-x width)))
1770           (:center (incf left (- point-x (round width 2)))
1771                    (incf right (- point-x (round width 2)))))
1772         (ecase align-y
1773           (:baseline (incf top point-y) (incf bottom point-y))
1774           (:top (incf top (+ point-y ascent))
1775                 (incf bottom (+ point-y ascent)))
1776           (:bottom (incf top (- point-y descent))
1777                    (incf bottom (- point-y descent)))
1778           (:center (incf top (+ point-y (ceiling (- ascent descent) 2)))
1779                    (incf bottom (+ point-y (ceiling (- ascent descent) 2)))))
1780         (values left top right bottom))))
1781    
1782    (defmethod* (setf output-record-position) :around
1783        (nx ny (record draw-text-output-record))
1784      (with-standard-rectangle* (:x1 x1 :y1 y1)
1785          record
1786        (with-slots (point-x point-y toward-x toward-y)
1787            record
1788          (let ((dx (- nx x1))
1789                (dy (- ny y1)))
1790            (multiple-value-prog1
1791                (call-next-method)
1792              (incf point-x dx)
1793              (incf point-y dy)
1794              (incf toward-x dx)
1795              (incf toward-y dy))))))
1796    
1797    (defrecord-predicate draw-text-output-record
1798        (string start end point-x point-y align-x align-y toward-x toward-y
1799         transform-glyphs)
1800      (and (if-supplied (string)
1801             (string= (slot-value record 'string) string))
1802           (if-supplied (start)
1803             (eql (slot-value record 'start) start))
1804           (if-supplied (end)
1805             (eql (slot-value record 'end) end))
1806           (if-supplied (point-x coordinate)
1807             (coordinate= (slot-value record 'point-x) point-x))
1808           (if-supplied (point-y coordinate)
1809             (coordinate= (slot-value record 'point-y) point-y))
1810           (if-supplied (align-x)
1811             (eq (slot-value record 'align-x) align-x))
1812           (if-supplied (align-y)
1813             (eq (slot-value record 'align-y) align-y))
1814           (if-supplied (toward-x coordinate)
1815             (coordinate= (slot-value record 'toward-x) toward-x))
1816           (if-supplied (toward-y coordinate)
1817             (coordinate= (slot-value record 'toward-y) toward-y))
1818           (if-supplied (transform-glyphs)
1819             (eq (slot-value record 'transform-glyphs) transform-glyphs))))
1820    
1821    ;;; 16.3.3. Text Displayed Output Record
1822    
1823    (defclass styled-string (gs-text-style-mixin gs-clip-mixin gs-ink-mixin)
1824      ((start-x :initarg :start-x)
1825       (string :initarg :string :reader styled-string-string)))
1826    
1827    (defmethod output-record-equal and ((record styled-string)
1828                                        (record2 styled-string))
1829      (and (coordinate= (slot-value record 'start-x)
1830                        (slot-value record2 'start-x))
1831           (string= (slot-value record 'string)
1832                    (slot-value record2 'string))))
1833    
1834    (defclass standard-text-displayed-output-record
1835        (text-displayed-output-record standard-displayed-output-record)
1836      ((initial-x1 :initarg :start-x)
1837       (initial-y1 :initarg :start-y)
1838       (strings :initform nil)
1839       (baseline :initform 0)
1840       (width :initform 0)
1841       (max-height :initform 0)
1842       ;; FIXME (or rework this comment): CLIM does not separate the
1843       ;; notions of the text width and the bounding box; however, we need
1844       ;; to, because some fonts will render outside the logical
1845       ;; coordinates defined by the start position and the width.  LEFT
1846       ;; and RIGHT here (and below) deal with this in a manner completely
1847       ;; hidden from the user.  (should we export
1848       ;; TEXT-BOUNDING-RECTANGLE*?)
1849       (left :initarg :start-x)
1850       (right :initarg :start-x)
1851       (start-x :initarg :start-x)
1852       (start-y :initarg :start-y)
1853       (end-x :initarg :start-x)
1854       (end-y :initarg :start-y)
1855       (wrapped :initform nil
1856                :accessor text-record-wrapped)
1857       (medium :initarg :medium :initform nil)))
1858    
1859    (defmethod initialize-instance :after
1860        ((obj standard-text-displayed-output-record) &key stream)
1861      (when stream
1862        (setf (slot-value obj 'medium) (sheet-medium stream))))
1863    
1864    ;;; Forget match-output-records-1 for standard-text-displayed-output-record; it
1865    ;;; doesn't make much sense because these records have state that is not
1866    ;;; initialized via initargs.
1867    
1868    (defmethod output-record-equal and
1869        ((record standard-text-displayed-output-record)
1870         (record2 standard-text-displayed-output-record))
1871      (with-slots
1872            (initial-x1 initial-y1 start-x start-y left right end-x end-y wrapped strings)
1873          record2
1874        (and (coordinate= (slot-value record 'initial-x1) initial-x1)
1875             (coordinate= (slot-value record 'initial-y1) initial-y1)
1876             (coordinate= (slot-value record 'start-x) start-x)
1877             (coordinate= (slot-value record 'start-y) start-y)
1878             (coordinate= (slot-value record 'left) left)
1879             (coordinate= (slot-value record 'right) right)
1880             (coordinate= (slot-value record 'end-x) end-x)
1881             (coordinate= (slot-value record 'end-y) end-y)
1882             (eq (slot-value record 'wrapped) wrapped)
1883             (coordinate= (slot-value record 'baseline)
1884                          (slot-value record2 'baseline))
1885             (eql (length (slot-value record 'strings)) (length strings));XXX
1886             (loop for s1 in (slot-value record 'strings)
1887                   for s2 in strings
1888                   always (output-record-equal s1 s2)))))
1889    
1890    (defmethod print-object ((self standard-text-displayed-output-record) stream)
1891      (print-unreadable-object (self stream :type t :identity t)
1892        (with-slots (start-x start-y strings) self
1893          (format stream "~D,~D ~S"
1894                  start-x start-y
1895                  (mapcar #'styled-string-string strings)))))
1896    
1897    (defmethod* (setf output-record-position) :around
1898        (nx ny (record standard-text-displayed-output-record))
1899      (with-standard-rectangle* (:x1 x1 :y1 y1)
1900          record
1901        (with-slots (start-x start-y end-x end-y strings baseline)
1902            record
1903          (let ((dx (- nx x1))
1904                (dy (- ny y1)))
1905            (multiple-value-prog1
1906                (call-next-method)
1907              (incf start-x dx)
1908              (incf start-y dy)
1909              (incf end-x dx)
1910              (incf end-y dy)
1911                                            ;(incf baseline dy)
1912              (loop for s in strings
1913                 do (incf (slot-value s 'start-x) dx)))))))
1914    
1915    (defmethod replay-output-record ((record standard-text-displayed-output-record)
1916                                     stream
1917                                     &optional region (x-offset 0) (y-offset 0))
1918      (declare (ignore region x-offset y-offset))
1919      (with-slots (strings baseline max-height start-y wrapped)
1920          record
1921        (with-sheet-medium (medium stream) ;is sheet a sheet-with-medium-mixin? --GB
1922          ;; FIXME:
1923          ;; 1. SLOT-VALUE...
1924          ;; 2. It should also save a "current line".
1925          (setf (slot-value stream 'baseline) baseline)
1926          (loop for substring in strings
1927                do (with-slots (start-x string)
1928                       substring
1929                     (setf (stream-cursor-position stream)
1930                           (values start-x start-y))
1931                     ;; FIXME: a bit of an abstraction inversion.  Should
1932                     ;; the styled strings here not simply be output
1933                     ;; records?  Then we could just replay them and all
1934                     ;; would be well.  -- CSR, 20060528.
1935                     ;; But then we'd have to implement the output record
1936                     ;; protocols for them. Are we allowed no internal
1937                     ;; structure of our own? -- Hefner, 20080118
1938    
1939                     ;; Some optimization might be possible here.
1940                     (with-drawing-options (stream
1941                                            :ink (graphics-state-ink substring)
1942                                            :clipping-region (graphics-state-clip substring)
1943                                            :text-style (graphics-state-text-style substring))
1944                       (stream-write-output stream string nil))))
1945          (when wrapped                     ; FIXME
1946            (draw-rectangle* medium
1947                             (+ wrapped 0) start-y
1948                             (+ wrapped 4) (+ start-y max-height)
1949                             :ink +foreground-ink+
1950                             :filled t)))))
1951    
1952  (defmethod scroll-horizontal :around ((stream stream-output-history-mixin) dx)  (defmethod output-record-start-cursor-position
1953    (declare (ignore dx))      ((record standard-text-displayed-output-record))
1954    (with-output-recording-options (stream :record nil)    (with-slots (start-x start-y) record
1955      (call-next-method)))      (values start-x start-y)))
1956    
1957    (defmethod output-record-end-cursor-position
1958  ;;; standard-tree-output-history class      ((record standard-text-displayed-output-record))
1959      (with-slots (end-x end-y) record
1960        (values end-x end-y)))
1961    
1962  (defclass standard-tree-output-history (stream-output-history-mixin)  (defmethod tree-recompute-extent
1963    (      ((text-record standard-text-displayed-output-record))
1964     ))    (with-standard-rectangle* (:y1 y1)
1965          text-record
1966        (with-slots (max-height left right)
1967            text-record
1968          (setf (rectangle-edges* text-record)
1969                (values (coordinate left)
1970                        y1
1971                        (coordinate right)
1972                        (coordinate (+ y1 max-height))))))
1973      text-record)
1974    
1975    (defmethod add-character-output-to-text-record ; XXX OAOO with ADD-STRING-...
1976        ((text-record standard-text-displayed-output-record)
1977         character text-style char-width height new-baseline)
1978      (with-slots (strings baseline width max-height left right start-y end-x end-y medium)
1979          text-record
1980        (if (and strings
1981                 (let ((string (last1 strings)))
1982                   (match-output-records string
1983                                         :text-style text-style
1984                                         :ink (medium-ink medium)
1985                                         :clipping-region (medium-clipping-region
1986                                                           medium))))
1987            (vector-push-extend character (slot-value (last1 strings) 'string))
1988            (nconcf strings
1989                    (list (make-instance
1990                           'styled-string
1991                           :start-x end-x
1992                           :text-style text-style
1993                           :medium medium   ; pick up ink and clipping region
1994                           :string (make-array 1 :initial-element character
1995                                               :element-type 'character
1996                                               :adjustable t
1997                                               :fill-pointer t)))))
1998        (multiple-value-bind (minx miny maxx maxy)
1999            (text-bounding-rectangle* medium character :text-style text-style)
2000          (declare (ignore miny maxy))
2001          (setq baseline (max baseline new-baseline)
2002                ;; KLUDGE: note END-X here is really START-X of the new
2003                ;; string
2004                left (min left (+ end-x minx))
2005                end-x (+ end-x char-width)
2006                right (+ end-x (max 0 (- maxx char-width)))
2007                max-height (max max-height height)
2008                end-y (max end-y (+ start-y max-height))
2009                width (+ width char-width))))
2010      (tree-recompute-extent text-record))
2011    
2012    (defmethod add-string-output-to-text-record
2013        ((text-record standard-text-displayed-output-record)
2014         string start end text-style string-width height new-baseline)
2015      (setf end (or end (length string)))
2016      (let ((length (max 0 (- end start))))
2017        (cond
2018          ((eql length 1)
2019           (add-character-output-to-text-record text-record
2020                                                (aref string start)
2021                                                text-style
2022                                                string-width height new-baseline))
2023          (t (with-slots (strings baseline width max-height left right start-y end-x end-y
2024                          medium)
2025                 text-record
2026               (let ((styled-string (make-instance
2027                                     'styled-string
2028                                     :start-x end-x
2029                                     :text-style text-style
2030                                     :medium medium
2031                                     :string (make-array length
2032                                                         :element-type 'character
2033                                                         :adjustable t
2034                                                         :fill-pointer t))))
2035                 (nconcf strings (list styled-string))
2036                 (replace (styled-string-string styled-string) string
2037                          :start2 start :end2 end))
2038               (multiple-value-bind (minx miny maxx maxy)
2039                   (text-bounding-rectangle* medium string
2040                                             :text-style text-style
2041                                             :start start :end end)
2042                 (declare (ignore miny maxy))
2043                 (setq baseline (max baseline new-baseline)
2044                       ;; KLUDGE: note that END-X here really means
2045                       ;; START-X of the new string.
2046                       left (min left (+ end-x minx))
2047                       end-x (+ end-x string-width)
2048                       right (+ end-x (max 0 (- maxx string-width)))
2049                       max-height (max max-height height)
2050                       end-y (max end-y (+ start-y max-height))
2051                       width (+ width string-width))))
2052             (tree-recompute-extent text-record)))))
2053    
2054  (defmethod initialize-instance :after ((history standard-tree-output-history) &rest args)  (defmethod text-displayed-output-record-string
2055    (declare (ignore args))      ((record standard-text-displayed-output-record))
2056    (with-slots (output-history) history    (with-slots (strings) record
2057      (setq output-history (make-instance 'standard-tree-output-record))))      (if (= 1 (length strings))
2058            (styled-string-string (first strings))
2059            (with-output-to-string (result)
2060              (loop for styled-string in strings
2061                do (write-string (styled-string-string styled-string) result))))))
2062    
2063    ;;; 16.3.4. Top-Level Output Records
2064  ;;; Output-Recording-Stream class  (defclass stream-output-history-mixin ()
2065      ((stream :initarg :stream :reader output-history-stream)))
2066    
2067    (defclass standard-sequence-output-history
2068        (standard-sequence-output-record stream-output-history-mixin)
2069      ())
2070    
2071  (defclass output-recording-stream (standard-tree-output-history)  (defclass standard-tree-output-history
2072    ((current-output-record      (standard-tree-output-record stream-output-history-mixin)
2073      :accessor stream-current-output-record)    ())
   
    ))  
2074    
2075  (defun output-recording-stream-p (x)  ;;; 16.4. Output Recording Streams
2076    (typep x 'output-recording-stream))  (defclass standard-output-recording-stream (output-recording-stream)
2077      ((recording-p :initform t :reader stream-recording-p)
2078       (drawing-p :initform t :accessor stream-drawing-p)
2079       (output-history :initform (make-instance 'standard-tree-output-history)
2080                       :reader stream-output-history)
2081       (current-output-record :accessor stream-current-output-record)
2082       (current-text-output-record :initform nil
2083                                   :accessor stream-current-text-output-record)
2084       (local-record-p :initform t
2085                       :documentation "This flag is used for dealing with streams outputting strings char-by-char.")))
2086    
2087  (defmethod initialize-instance :after ((stream output-recording-stream) &rest args)  (defmethod initialize-instance :after
2088        ((stream standard-output-recording-stream) &rest args)
2089    (declare (ignore args))    (declare (ignore args))
2090      (let ((history (make-instance 'standard-tree-output-history :stream stream)))
2091        (setf (slot-value stream 'output-history) history
2092              (stream-current-output-record stream) history)))
2093    
2094    ;;; Used in initializing clim-stream-pane
2095    
2096    (defmethod reset-output-history ((stream
2097                                      standard-output-recording-stream))
2098      (setf (slot-value stream 'output-history)
2099            (make-instance 'standard-tree-output-history :stream stream))
2100    (setf (stream-current-output-record stream) (stream-output-history stream)))    (setf (stream-current-output-record stream) (stream-output-history stream)))
2101    
2102  (defmethod stream-add-output-record ((stream output-recording-stream) record)  ;;; 16.4.1 The Output Recording Stream Protocol
2103    (defmethod (setf stream-recording-p)
2104        (recording-p (stream standard-output-recording-stream))
2105      (let ((old-val (slot-value stream 'recording-p)))
2106        (setf (slot-value stream 'recording-p) recording-p)
2107        (when (not (eq old-val recording-p))
2108          (stream-close-text-output-record stream))
2109        recording-p))
2110    
2111    (defmethod stream-add-output-record
2112        ((stream standard-output-recording-stream) record)
2113    (add-output-record record (stream-current-output-record stream)))    (add-output-record record (stream-current-output-record stream)))
2114    
2115  (defmethod stream-replay ((stream output-recording-stream) &optional region)  (defmethod stream-replay
2116        ((stream standard-output-recording-stream) &optional region)
2117    (replay (stream-output-history stream) stream region))    (replay (stream-output-history stream) stream region))
2118    
2119  (defclass standard-output-recording-stream (output-recording-stream)  (defun output-record-ancestor-p (ancestor child)
2120    (    (loop for record = child then parent
2121     ))       for parent = (output-record-parent record)
2122         when (eq parent nil) do (return nil)
2123  (defmacro with-output-recording-options ((stream &key (record t) (draw t)) &body body)       when (eq parent ancestor) do (return t)))
2124    (let ((old-record (gensym))  
2125          (old-draw (gensym)))  (defun rounded-bounding-rectangle (region)
2126      `(with-slots (recording-p drawing-p) ,stream    ;; return a bounding rectangle whose coordinates have been rounded to
2127         (let ((,old-record recording-p)    ;; lock into the pixel grid.  Includes some extra safety to make
2128               (,old-draw drawing-p))    ;; sure antialiasing around the theoretical limits are included, too.
2129           (unwind-protect    (with-bounding-rectangle* (x1 y1 x2 y2) region
2130               (progn      (make-rectangle*  (floor (- x1 0.5))
2131                 (setq recording-p ,record                        (floor (- y1 0.5))
2132                       drawing-p ,draw)                        (ceiling (+ x2 0.5))
2133                 ,@body)                        (ceiling (+ y2 0.5)))))
2134             (setq recording-p ,old-record  
2135                   drawing-p ,old-draw))))))  (defmethod erase-output-record (record (stream standard-output-recording-stream)
2136                                    &optional (errorp t))
2137      (letf (((stream-recording-p stream)  nil))
2138        (let ((region (rounded-bounding-rectangle record)))
2139          (with-bounding-rectangle* (x1 y1 x2 y2) region
2140            (if (output-record-ancestor-p (stream-output-history stream) record)
2141                (progn
2142                  (delete-output-record record (output-record-parent record))
2143                  (with-output-recording-options (stream :record nil)
2144                    (draw-rectangle* stream x1 y1 x2 y2 :ink +background-ink+))
2145                  (stream-replay stream region))
2146                (when errorp
2147                  (error "~S is not contained in ~S." record stream)))))))
2148    
2149    ;;; 16.4.3. Text Output Recording
2150    (defmethod stream-text-output-record
2151        ((stream standard-output-recording-stream) text-style)
2152      (declare (ignore text-style))
2153      (let ((record (stream-current-text-output-record stream)))
2154        (unless (and record (typep record 'standard-text-displayed-output-record))
2155          (multiple-value-bind (cx cy) (stream-cursor-position stream)
2156            (setf record (make-instance 'standard-text-displayed-output-record
2157                                        :x-position cx :y-position cy
2158                                        :start-x cx :start-y cy
2159                                        :stream stream)
2160                  (stream-current-text-output-record stream) record)))
2161        record))
2162    
2163    (defmethod stream-close-text-output-record
2164        ((stream standard-output-recording-stream))
2165      (let ((record (stream-current-text-output-record stream)))
2166        (when record
2167          (setf (stream-current-text-output-record stream) nil)
2168          #|record stream-current-cursor-position to (end-x record) - already done|#
2169          (stream-add-output-record stream record))))
2170    
2171    (defmethod stream-add-character-output
2172        ((stream standard-output-recording-stream)
2173         character text-style width height baseline)
2174      (add-character-output-to-text-record
2175       (stream-text-output-record stream text-style)
2176       character text-style width height baseline))
2177    
2178    (defmethod stream-add-string-output ((stream standard-output-recording-stream)
2179                                         string start end text-style
2180                                         width height baseline)
2181      (add-string-output-to-text-record (stream-text-output-record stream
2182                                                                   text-style)
2183                                        string start end text-style
2184                                        width height baseline))
2185    
2186    ;;; Text output catching methods
2187    (defmacro without-local-recording (stream &body body)
2188      `(letf (((slot-value ,stream 'local-record-p) nil))
2189         ,@body))
2190    
2191    (defmethod stream-write-output :around
2192        ((stream standard-output-recording-stream)
2193         line
2194         string-width
2195         &optional (start 0) end)
2196    
2197      (when (and (stream-recording-p stream)
2198                 (slot-value stream 'local-record-p))
2199        (let* ((medium (sheet-medium stream))
2200               (text-style (medium-text-style medium))
2201               (height (text-style-height text-style medium))
2202               (ascent (text-style-ascent text-style medium)))
2203          (if (characterp line)
2204              (stream-add-character-output stream line text-style
2205                                           (stream-character-width
2206                                            stream line :text-style text-style)
2207                                           height
2208                                           ascent)
2209              (stream-add-string-output stream line start end text-style
2210                                        (or string-width
2211                                            (stream-string-width stream line
2212                                                             :start start :end end
2213                                                             :text-style text-style))
2214                                        height
2215                                        ascent))))
2216    
2217      (when (stream-drawing-p stream)
2218        (without-local-recording stream
2219          (call-next-method))))
2220    
2221    #+nil
2222    (defmethod stream-write-char :around ((stream standard-output-recording-stream) char)
2223      (when (and (stream-recording-p stream)
2224                 (slot-value stream 'local-record-p))
2225        (if (or (eql char #\return)
2226    
2227            (stream-close-text-output-record stream)
2228          (let* ((medium (sheet-medium stream))
2229                 (text-style (medium-text-style medium)))
2230            (stream-add-character-output stream char text-style
2231                                         (stream-character-width stream char :text-style text-style)
2232                                         (text-style-height text-style medium)
2233                                         (text-style-ascent text-style medium)))))
2234      (without-local-recording stream
2235                               (call-next-method))))
2236    
2237    #+nil
2238    (defmethod stream-write-string :around ((stream standard-output-recording-stream) string
2239                                            &optional (start 0) end)
2240      (when (and (stream-recording-p stream)
2241                 (slot-value stream 'local-record-p))
2242        (let* ((medium (sheet-medium stream))
2243               (text-style (medium-text-style medium)))
2244          (stream-add-string-output stream string start end text-style
2245                                    (stream-string-width stream string
2246                                                         :start start :end end
2247                                                         :text-style text-style)
2248                                    (text-style-height text-style medium)
2249                                    (text-style-ascent text-style medium))))
2250      (without-local-recording stream
2251                               (call-next-method)))
2252    
2253    
2254    (defmethod stream-finish-output :after ((stream standard-output-recording-stream))
2255      (stream-close-text-output-record stream))
2256    
2257    (defmethod stream-force-output :after ((stream standard-output-recording-stream))
2258  ;;; graphics and text recording classes    (stream-close-text-output-record stream))
2259    
2260  (eval-when (compile load eval)  (defmethod stream-terpri :after ((stream standard-output-recording-stream))
2261      (stream-close-text-output-record stream))
   (defun compute-class-vars (names)  
     (cons (list 'stream :initarg :stream)  
           (loop for name in names  
                 collecting (list name :initarg (intern name :keyword)))))  
   
   (defun compute-arg-list (names)  
     (loop for name in names  
           nconcing (list (intern name :keyword) name)))  
   )  
   
 (defun make-merged-medium (sheet ink clip transform line-style text-style)  
   (let ((medium (make-medium (port sheet) sheet)))  
     (setf (medium-ink medium) ink)  
     (setf (medium-clipping-region medium) clip)  
     (setf (medium-transformation medium) transform)  
     (setf (medium-line-style medium) line-style)  
     (setf (medium-text-style medium) text-style)  
     medium))  
   
 (defmacro def-grecording (name (&rest args) &body body)  
   (declare (ignore path))  
   (let ((method-name (intern (format nil "MEDIUM-~A*" name)))  
         (class-name (intern (format nil "~A-OUTPUT-RECORD" name)))  
         (old-medium (gensym))  
         (new-medium (gensym)))  
     `(eval-when (eval load compile)  
        (defclass ,class-name (graphics-displayed-output-record)  
          ,(compute-class-vars args))  
        (defmethod initialize-instance :after ((graphic ,class-name) &rest args)  
          (declare (ignore args))  
          (with-slots (x-min y-min x-max y-max  
                       stream ink clipping-region transformation  
                       line-style text-style  
                       ,@args) graphic  
            (multiple-value-bind (lf tp rt bt) (progn ,@body)  
              (setq x-min lf  
                    y-min tp  
                    x-max rt  
                    y-max bt))))  
        (defmethod ,method-name :around ((stream stream-output-history-mixin) ,@args)  
          (with-sheet-medium (medium stream)  
            (let ((record (make-instance ',class-name  
                            :stream stream  
                            :ink (medium-ink medium)  
                            :clipping-region (medium-clipping-region medium)  
                            :transformation (medium-transformation medium)  
                            :line-style (medium-line-style medium)  
                            :text-style (medium-text-style medium)  
                            ,@(compute-arg-list args))))  
              (when (stream-recording-p stream)  
                (add-output-record record (stream-output-history stream))  
                )  
              (when (stream-drawing-p stream)  
                (call-next-method)))))  
        (defmethod replay-output-record ((record ,class-name) stream  
                                         &optional region x-offset y-offset)  
          (declare (ignore region x-offset y-offset))  
          (with-slots (ink clip transform line-style text-style ,@args) record  
            (let ((,old-medium (sheet-medium stream))  
                  (,new-medium (make-merged-medium stream ink clip transform line-style text-style)))  
              (unwind-protect  
                  (progn  
                    (setf (sheet-medium stream) ,new-medium)  
                    (setf (medium-sheet ,new-medium) stream)  
                    (,method-name ,new-medium ,@args))  
                (setf (sheet-medium stream) ,old-medium))))))))  
   
 (def-grecording draw-point (x y)  
   (values x y x y))  
   
 (def-grecording draw-points (coord-seq)  
   (loop for (x y) on coord-seq by #'cddr  
         minimize x into min-x  
         minimize y into min-y  
         maximize x into max-x  
         maximize y into max-y  
         finally (return (values min-x min-y max-x max-y))))  
   
 (def-grecording draw-line (x1 y1 x2 y2)  
   (values (min x1 x2) (min y1 y2) (max x1 x2) (max y1 y2)))  
   
 (def-grecording draw-lines (coord-seq)  
   (loop for (x y) on coord-seq by #'cddr  
         minimize x into min-x  
         minimize y into min-y  
         maximize x into max-x  
         maximize y into max-y  
         finally (return (values min-x min-y max-x max-y))))  
   
 (def-grecording draw-polygon (coord-seq closed filled)  
   (loop for (x y) on coord-seq by #'cddr  
         minimize x into min-x  
         minimize y into min-y  
         maximize x into max-x  
         maximize y into max-y  
         finally (return (values min-x min-y max-x max-y))))  
2262    
2263  (def-grecording draw-rectangle (left top right bottom filled)  (defmethod* (setf stream-cursor-position) :after (x y (stream standard-output-recording-stream))
2264    (values (min left right) (min top bottom) (max left right) (max top bottom)))    (declare (ignore x y))
2265      (stream-close-text-output-record stream))
2266    
2267  (def-grecording draw-ellipse (center-x center-y  ;(defmethod stream-set-cursor-position :after ((stream standard-output-recording-stream))
2268                                radius-1-dx radius-1-dy radius-2-dx radius-2-dy  ;  (stream-close-text-output-record stream))
                               start-angle end-angle filled)  
   (values center-x center-y center-x center-y))  
2269    
2270  (def-grecording draw-text (string x y start end  (defmethod stream-wrap-line :before ((stream standard-output-recording-stream))
2271                             align-x align-y toward-x toward-y transform-glyphs)    (when (stream-recording-p stream)
2272    (let* ((width (stream-string-width stream string      (setf (text-record-wrapped (stream-text-output-record stream nil)) ; FIXME!
2273                                       :start start :end end            (stream-text-margin stream))))
2274                                       :text-style text-style))  
2275           (ascent (text-style-ascent (port (sheet-medium stream)) text-style))  ;;; 16.4.4. Output Recording Utilities
2276           (descent (text-style-descent (port (sheet-medium stream)) text-style))  
2277           (height (+ ascent descent))  (defmethod invoke-with-output-recording-options
2278           left top right bottom)    ((stream output-recording-stream) continuation record draw)
2279      (ecase align-x    "Calls CONTINUATION on STREAM enabling or disabling recording and drawing
2280        (:left (setq left x  according to the flags RECORD and DRAW."
2281                     right (+ x width)))    (letf (((stream-recording-p stream) record)
2282        (:right (setq left (- x width)           ((stream-drawing-p stream) draw))
2283                      right x))      (funcall continuation stream)))
2284        (:center (setq left (- x (round width 2))  
2285                       right (+ x (round width 2)))))  (defmethod invoke-with-new-output-record ((stream output-recording-stream)
2286      (ecase align-y                                            continuation record-type
2287        (:baseline (setq top (- y height)                                            constructor
2288                         bottom (+ y descent)))                                            &key parent)
2289        (:top (setq top y    (declare (ignore record-type))
2290                    bottom (+ y height)))    (stream-close-text-output-record stream)
2291        (:bottom (setq top (- y height)    (let ((new-record (funcall constructor)))
2292                       bottom y))      (letf (((stream-current-output-record stream) new-record))
2293        (:center (setq top (- y (floor height 2))        ;; Should we switch on recording? -- APD
2294                       bottom (+ y (ceiling height 2)))))        (funcall continuation stream new-record)
2295      (values left top right bottom)))        (force-output stream))
2296        (if parent
2297            (add-output-record new-record parent)
2298            (stream-add-output-record stream new-record))
2299        new-record))
2300    
2301    (defmethod invoke-with-new-output-record ((stream output-recording-stream)
2302                                              continuation record-type
2303                                              (constructor null)
2304                                              &rest initargs
2305                                              &key parent)
2306      (with-keywords-removed (initargs (:parent))
2307        (stream-close-text-output-record stream)
2308        (let ((new-record (apply #'make-instance record-type initargs)))
2309          (letf (((stream-current-output-record stream) new-record))
2310            ;; Should we switch on recording? -- APD
2311            (funcall continuation stream new-record)
2312            (force-output stream))
2313          (if parent
2314              (add-output-record new-record parent)
2315              (stream-add-output-record stream new-record))
2316          new-record)))
2317    
2318    (defmethod invoke-with-output-to-output-record
2319        ((stream output-recording-stream) continuation record-type constructor
2320         &key)
2321      (declare (ignore record-type))
2322      (stream-close-text-output-record stream)
2323      (let ((new-record (funcall constructor)))
2324        (with-output-recording-options (stream :record t :draw nil)
2325          (letf (((stream-current-output-record stream) new-record)
2326                 ((stream-cursor-position stream) (values 0 0)))
2327            (funcall continuation stream new-record)
2328            (force-output stream)))
2329        new-record))
2330    
2331    (defmethod invoke-with-output-to-output-record
2332        ((stream output-recording-stream) continuation record-type (constructor null)
2333         &rest initargs)
2334      (stream-close-text-output-record stream)
2335      (let ((new-record (apply #'make-instance record-type initargs)))
2336        (with-output-recording-options (stream :record t :draw nil)
2337          (letf (((stream-current-output-record stream) new-record)
2338                 ((stream-cursor-position stream) (values 0 0)))
2339            (funcall continuation stream new-record)
2340            (force-output stream)))
2341        new-record))
2342    
2343    (defmethod make-design-from-output-record (record)
2344      ;; FIXME
2345      (declare (ignore record))
2346      (error "Not implemented."))
2347    
2348    
2349  ;;; Text recording class  ;;; Additional methods
2350    (defmethod scroll-vertical :around ((stream output-recording-stream) dy)
2351      (declare (ignore dy))
2352      (with-output-recording-options (stream :record nil)
2353        (call-next-method)))
2354    
2355  (defclass text-displayed-output-record (displayed-output-record)  (defmethod scroll-horizontal :around ((stream output-recording-stream) dx)
2356    ((strings :initform nil)    (declare (ignore dx))
2357     (baseline :initform 0)    (with-output-recording-options (stream :record nil)
2358     (max-height :initform 0)      (call-next-method)))
    (start-x :initarg :start-x  
             :initform 0)  
    (start-y :initarg :start-y  
             :initform 0)  
    (end-x)  
    (end-y)))  
2359    
2360  (defmethod initialize-instance :after ((record text-displayed-output-record) &rest args)  ;;; FIXME: Change things so the rectangle below is only drawn in response
2361    (declare (ignore args))  ;;;        to explicit repaint requests from the user, not exposes from X
2362    (with-slots (start-x start-y end-x end-y) record  ;;; FIXME: Use DRAW-DESIGN*, that is fix DRAW-DESIGN*.
2363      (setq end-x start-x  
2364            end-y start-y)))  (defmethod handle-repaint ((stream output-recording-stream) region)
2365      (when (output-recording-stream-p stream)
2366  (defun text-displayed-output-record-p (x)      (unless (region-equal region +nowhere+)                    ; ignore repaint requests for +nowhere+
2367    (typep x 'text-displayed-output-record))        (let ((region (if (region-equal region +everywhere+)
2368                            (sheet-region stream)                  ; fallback to the sheet's region for +everwhere+
2369                          (bounding-rectangle region))))
2370  (defmethod add-character-output-to-text-record ((text-record text-displayed-output-record)          (with-bounding-rectangle* (x1 y1 x2 y2) region
2371                                                  character text-style width height            (with-output-recording-options (stream :record nil)
2372                                                  new-baseline)              (draw-rectangle* stream x1 y1 x2 y2 :filled t :ink +background-ink+)))
2373    (with-slots (strings baseline max-height end-x) text-record          (stream-replay stream region)))))
     (setq baseline new-baseline  
           strings (nconc strings (list (list end-x text-style (make-string 1 :initial-element character))))  
           end-x (+ end-x width)  
           max-height (max max-height height)  
           )))  
   
 (defmethod add-string-output-to-text-record ((text-record text-displayed-output-record)  
                                              string start end text-style width height  
                                              new-baseline)  
   (with-slots (strings baseline max-height end-x) text-record  
     (setq baseline new-baseline  
           strings (nconc strings (list (list end-x text-style (subseq string start end))))  
           end-x (+ end-x width)  
           max-height (max max-height height)  
           )))  
2374    
 (defmethod replay-output-record ((record text-displayed-output-record) stream  
                                  &optional region x-offset y-offset)  
   (declare (ignore x-offset y-offset))  
   (with-slots (strings baseline max-height start-x start-y) record  
     (loop for y = start-y  
           for (x text-style string) in strings  
           do (draw-text* stream string x y :text-style text-style :clipping-region region))))  
2375    
2376  (defmethod output-record-start-cursor-position ((record text-displayed-output-record))  (defmethod scroll-extent :around ((stream output-recording-stream) x y)
2377    (with-slots (start-x start-y) record    (declare (ignore x y))
2378      (values start-x start-y)))    (when (stream-drawing-p stream)
2379        (call-next-method)))
2380    
2381  (defmethod output-record-end-cursor-position ((record text-displayed-output-record))  ;;; ----------------------------------------------------------------------------
2382    (with-slots (end-x end-y) record  ;;; Complicated, underspecified...
2383      (values end-x end-y)))  ;;;
2384    ;;; From examining old Genera documentation, I believe that
2385    ;;; with-room-for-graphics is supposed to set the medium transformation to
2386    ;;; give the desired coordinate system; i.e., it doesn't preserve any
2387    ;;; rotation, scaling or translation in the current medium transformation.
2388    (defmethod invoke-with-room-for-graphics (cont stream
2389                                              &key (first-quadrant t)
2390                                              height
2391                                              (move-cursor t)
2392                                              (record-type
2393                                               'standard-sequence-output-record))
2394      ;; I am not sure what exactly :height should do.
2395      ;; --GB 2003-05-25
2396      ;; The current behavior is consistent with 'classic' CLIM
2397      ;; --Hefner 2004-06-19
2398      ;; Don't know if it still is :)
2399      ;; -- Moore 2005-01-26
2400      (multiple-value-bind (cx cy)
2401          (stream-cursor-position stream)
2402        (with-sheet-medium (medium stream)
2403          (letf (((medium-transformation medium)
2404                  (if first-quadrant
2405                      (make-scaling-transformation 1 -1)
2406                      +identity-transformation+)))
2407            (let ((record (with-output-to-output-record (stream record-type)
2408                            (funcall cont stream))))
2409              ;; Bounding  rectangle is in sheet coordinates!
2410              (with-bounding-rectangle* (x1 y1 x2 y2)
2411                  record
2412                (declare (ignore x2))
2413                (if first-quadrant
2414                    (setf (output-record-position record)
2415                          (values (max cx (+ cx x1))
2416                                  (if height
2417                                      (max cy (+ cy (- height (- y2 y1))))
2418                                      cy)))
2419                    (setf (output-record-position record)
2420                          (values (max cx (+ cx x1)) (max cy (+ cy y1)))))
2421                (when (stream-recording-p stream)
2422                  (stream-add-output-record stream record))
2423                (when (stream-drawing-p stream)
2424                  (replay record stream))
2425                (if move-cursor
2426                    (let ((record-height (- y2 y1)))
2427                      (setf (stream-cursor-position stream)
2428                            (values cx
2429                                    (if first-quadrant
2430                                        (+ cy (max (- y1)
2431                                                   (or height 0)
2432                                                   record-height))
2433                                        (+ cy (max (or height 0)
2434                                                   record-height))))))
2435                    (setf (stream-cursor-position stream) (values cx cy)))
2436                record))))))
2437    
2438  (defmethod text-displayed-output-record-string ((record text-displayed-output-record))  ;;; ----------------------------------------------------------------------------
2439    (with-slots (strings) record  ;;;  Baseline
2440      (loop for result = ""  ;;;
2441            for s in strings  
2442            do (setq result (concatenate 'string result (third s)))  (defmethod output-record-baseline ((record output-record))
2443               finally (return result))))    "Fall back method"
2444      (with-bounding-rectangle* (x1 y1 x2 y2)
2445          record
2446        (declare (ignore x1 x2))
2447        (values (- y2 y1) nil)))
2448    
2449    (defmethod output-record-baseline ((record standard-text-displayed-output-record))
2450      (with-slots (baseline) record
2451        (values
2452         baseline
2453         t)))
2454    
2455    (defmethod output-record-baseline ((record compound-output-record))
2456      (map-over-output-records (lambda (sub-record)
2457                                 (multiple-value-bind (baseline definitive)
2458                                     (output-record-baseline sub-record)
2459                                   (when definitive
2460                                     (return-from output-record-baseline
2461                                       (values baseline t)))))
2462                               record)
2463      (call-next-method))
2464    
2465    ;;; ----------------------------------------------------------------------------
2466    ;;;  copy-textual-output
2467    ;;;
2468    
2469    (defun copy-textual-output-history (window stream &optional region record)
2470      (unless region (setf region +everywhere+))
2471      (unless record (setf record (stream-output-history window)))
2472      (let* ((text-style (medium-default-text-style window))
2473             (char-width (stream-character-width window #\n :text-style text-style))
2474             (line-height (+ (stream-line-height window :text-style text-style)
2475                             (stream-vertical-spacing window))))
2476        #+NIL
2477        (print (list char-width line-height
2478                     (stream-line-height window :text-style text-style)
2479                     (stream-vertical-spacing window))
2480               *trace-output*)
2481        ;; humble first ...
2482        (let ((cy nil)
2483              (cx 0))
2484          (labels ((grok-record (record)
2485                     (cond ((typep record 'standard-text-displayed-output-record)
2486                            (with-slots (start-y start-x end-x strings) record
2487                              (setf cy (or cy start-y))
2488                              #+NIL
2489                              (print (list (list cx cy)
2490                                           (list start-x end-x start-y))
2491                                     *trace-output*)
2492                              (when (> start-y cy)
2493                                (dotimes (k (round (- start-y cy) line-height))
2494                                  (terpri stream))
2495                                (setf cy start-y
2496                                      cx 0))
2497                              (dotimes (k (round (- start-x cx) char-width))
2498                                (princ " " stream))
2499                              (setf cx end-x)
2500                              (dolist (string strings)
2501                                (with-slots (string) string
2502                                  (princ string stream))
2503                                #+NIL
2504                                (print (list start-x start-y string)
2505                                       *trace-output*))))
2506                           (t
2507                            (map-over-output-records-overlapping-region #'grok-record
2508                                                                        record region)))))
2509            (grok-record record)))))
2510    
2511    ;;; Debugging hacks
2512    
2513    (defmethod count-records (r)
2514      (declare (ignore r))
2515      1)
2516    
2517    (defmethod count-records ((r compound-output-record))
2518      (let ((count 0))
2519        (map-over-output-records
2520         (lambda (child)
2521           (incf count (count-records child)))
2522         r)
2523        (1+ count)))
2524    
2525    (defmethod count-displayed-records ((r displayed-output-record))
2526      1)
2527    
2528    (defmethod count-displayed-records ((r compound-output-record))
2529      (let ((count 0))
2530        (map-over-output-records
2531         (lambda (child)
2532           (incf count (count-records child)))
2533         r)
2534        count))

Legend:
Removed from v.1.1.1.1  
changed lines
  Added in v.1.145

  ViewVC Help
Powered by ViewVC 1.1.5