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

Diff of /mcclim/recording.lisp

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

revision 1.45 by adejneka, Sun Jun 9 15:37:51 2002 UTC revision 1.46 by adejneka, Fri Jun 14 06:15:49 2002 UTC
# Line 30  Line 30 
30  ;;;   compound records  ;;;   compound records
31  ;;; - How to deal with mixing of positioning/modifying?  ;;; - How to deal with mixing of positioning/modifying?
32  ;;; - When DRAWING-P is NIL, should stream cursor move?  ;;; - When DRAWING-P is NIL, should stream cursor move?
33  ;;; - OUTPUT-RECORD is a protocol class, it should not have any slots/methods.  ;;; - STANDARD-TEXT-DISPLAYED-OUTPUT-RECORD does not store current
34  ;;; - TEXT-DISPLAYED-OUTPUT-RECORD-MIXIN does not store current ink.  ;;;   ink, clipping region.
 ;;; - There are glitches with O-R-POSITION.  
35    
36  (in-package :CLIM-INTERNALS)  ;;; There is a problem. Some GFs are defined to have "a default method
37    ;;; on CGLIM's standard output record class". What does it mean? What
38  ;;; Should we blow off standard-bounding-rectangle and implement the  ;;; is "CLIM's standard output record class"? Is it OUTPUT-RECORD or
39  ;;; bounding rectangle protocol ourselves?  Or use x1,y1 from  ;;; BASIC-OUTPUT-RECORD? Now they are defined on OUTPUT-RECORD and
40  ;;; standard-bounding-rectangle as our position?  ;;; marked with "XXX DC".
   
 (defclass basic-output-record (bounding-rectangle)  
   ()  
   (:documentation "Internal protocol class for common elements of output-record  
  and displayed-output-record"))  
   
 (defclass basic-output-record-mixin (standard-bounding-rectangle  
                                      basic-output-record)  
   ((x :initarg :x-position  
       :initform 0  
       :type rational)  
    (y :initarg :y-position  
       :initform 0  
       :type rational)  
    (parent :initarg :parent  
            :initform nil  
            :reader output-record-parent))  
   (:documentation "Implementation class for the Basic Output Record Protocol"))  
41    
42  (defmethod initialize-instance :after ((record basic-output-record-mixin)  (in-package :CLIM-INTERNALS)
                                        &rest args)  
   (declare (ignore args))  
   (with-slots (x y x1 y1 x2 y2) record  
     (setq x1 x  
           y1 y  
           x2 x  
           y2 y)))  
43    
44  (defclass output-record (basic-output-record)  (define-protocol-class output-record (bounding-rectangle)
45    ())    ())
46    
47  (defun output-record-p (x)  (define-protocol-class displayed-output-record (output-record)
   (typep x 'output-record))  
   
 (defclass output-record-mixin (basic-output-record-mixin output-record)  
   ()  
   (:documentation "Implementation class for output records i.e., those records  
  that have children."))  
   
 (defclass displayed-output-record (basic-output-record)  
48    ())    ())
49    
50  (defclass displayed-output-record-mixin (basic-output-record-mixin  ;;; 16.2.1. The Basic Output Record Protocol
                                          displayed-output-record)  
   ((ink :initarg :ink :reader displayed-output-record-ink)  
    (initial-x1 :initarg :initial-x1)  
    (initial-y1 :initarg :initial-y1))  
   (:documentation "Implementation class for displayed-output-record."))  
   
 (defun displayed-output-record-p (x)  
   (typep x 'displayed-output-record))  
   
 ; 16.2.1. The Basic Output Record Protocol  
51  #+:cmu(declaim (ftype (function (output-record) (values rational rational))  #+:cmu(declaim (ftype (function (output-record) (values rational rational))
52                        output-record-position))                        output-record-position))
53  (defgeneric output-record-position (record)  (defgeneric output-record-position (record)
# Line 125  upper-left corner of the stream.")) Line 81  upper-left corner of the stream."))
81    
82  (defgeneric output-record-parent (record)  (defgeneric output-record-parent (record)
83    (:documentation    (:documentation
84     "Returns the output record that is the parent of RECORD, or nil if     "Returns the output record that is the parent of RECORD, or NIL if
85  RECORD has no parent."))  RECORD has no parent."))
86    
87  (defgeneric replay-output-record (record stream  (defgeneric replay-output-record (record stream
# Line 146  Only those records that overlap REGION a Line 102  Only those records that overlap REGION a
102    
103  (defgeneric displayed-output-record-ink (displayed-output-record))  (defgeneric displayed-output-record-ink (displayed-output-record))
104    
105  ; 16.2.2. Output Record "Database" Protocol  ;;; 16.2.2. Output Record "Database" Protocol
106    
107  (defgeneric output-record-children (record))  (defgeneric output-record-children (record))
108    
109  (defgeneric add-output-record (child record))  (defgeneric add-output-record (child record))
110    
111  (defgeneric delete-output-record (child record &optional (errorp t)))  (defgeneric delete-output-record (child record &optional errorp))
112    
113  (defgeneric clear-output-record (record))  (defgeneric clear-output-record (record))
114    
115  (defgeneric output-record-count (record))  (defgeneric output-record-count (record))
116    
117  (defgeneric map-over-output-records-containing-position  (defgeneric map-over-output-records-containing-position
118    (function record x y &optional x-offset y-offset &rest function-args))    (function record x y &optional x-offset y-offset &rest function-args)
119      (:documentation "Maps over all of the children of RECORD that
120    contain the point at (X,Y), calling FUNCTION on each one. FUNCTION is
121    a function of one or more arguments, the first argument being the
122    record containing the point. FUNCTION is also called with all of
123    FUNCTION-ARGS as APPLY arguments.
124    
125    If there are multiple records that contain the point,
126    MAP-OVER-OUTPUT-RECORDS-CONTAINING-POSITION hits the most recently
127    inserted record first and the least recently inserted record
128    last. Otherwise, the order in which the records are traversed is
129    unspecified."))
130    
131  (defgeneric map-over-output-records-overlapping-region  (defgeneric map-over-output-records-overlapping-region
132    (function record region &optional x-offset y-offset &rest function-args))    (function record region &optional x-offset y-offset &rest function-args)
133      (:documentation "Maps over all of the children of the RECORD that
134    overlap the REGION, calling FUNCTION on each one. FUNCTION is a
135    function of one or more arguments, the first argument being the record
136    overlapping the region. FUNCTION is also called with all of
137    FUNCTION-ARGS as APPLY arguments.
138    
139    If there are multiple records that overlap the region and that overlap
140    each other, MAP-OVER-OUTPUT-RECORDS-OVERLAPPING-REGION hits the least
141    recently inserted record first and the most recently inserted record
142    last. Otherwise, the order in which the records are traversed is
143    unspecified. "))
144    
145  ;;; From the Franz CLIM user's guide but not in the spec... clearly necessary.  ;;; From the Franz CLIM user's guide but not in the spec... clearly necessary.
146    ;;; What is its status? -- APD, 2002-06-14.
147  (defgeneric map-over-output-records  (defgeneric map-over-output-records
148      (continuation record &optional x-offset y-offset &rest continuation-args))      (continuation record &optional x-offset y-offset &rest continuation-args))
149    
150  ; 16.2.3. Output Record Change Notification Protocol  ;;; 16.2.3. Output Record Change Notification Protocol
151    
152  (defgeneric recompute-extent-for-new-child (record child))  (defgeneric recompute-extent-for-new-child (record child))
153    
# Line 177  Only those records that overlap REGION a Line 156  Only those records that overlap REGION a
156    
157  (defgeneric tree-recompute-extent (record))  (defgeneric tree-recompute-extent (record))
158    
159  ;;; Methods  ;;; 16.3. Types of Output Records
160    (define-protocol-class graphics-displayed-output-record (output-record)
161      ())
162    
163  (defmethod output-record-position ((record basic-output-record-mixin))  (define-protocol-class text-displayed-output-record (displayed-output-record)
164    (with-slots (x y) record    ())
     (values x y)))  
   
 (defvar *suppress-notify-parent* nil  
   "When t, don't notify the parent of a change in an output record's  
    bounding rectangle.")  
165    
166  (defmethod* (setf output-record-position)  ;;; 16.3.3. Text Displayed Output Record
167      (nx ny (record basic-output-record-mixin))  (defgeneric add-character-output-to-text-record
168    (with-slots (x y x1 y1 x2 y2) record    (text-record character text-style width height baseline))
     (let ((dx (- nx x))  
           (dy (- ny y)))  
       (incf x1 dx) (incf y1 dy)  
       (incf x2 dx) (incf y2 dy))  
     (setq x nx  
           y ny)))  
169    
170  (defmethod* (setf output-record-position) :before  (defgeneric add-string-output-to-text-record
171      (nx ny (record output-record))    (text-record string start end text-style width height baseline))
172    (let ((*suppress-notify-parent* t))  
173      (multiple-value-bind (old-x old-y) (output-record-position record)  (defgeneric text-displayed-output-record-string (text-record))
174        (let ((dx (- nx old-x))  
175              (dy (- ny old-y)))  ;;; 16.4. Output Recording Streams
176          (map-over-output-records  (define-protocol-class output-recording-stream ()
177           #'(lambda (child)    ())
178               (multiple-value-bind (x y) (output-record-position child)  
179                 (setf (output-record-position child)  ;;; 16.4.1. The Output Recording Stream Protocol
180                       (values (+ x dx) (+ y dy)))))  (defgeneric stream-recording-p (stream))
181           record)))))  
182    (defgeneric (setf stream-recording-p) (recording-p stream))
183    
184    (defgeneric stream-drawing-p (stream))
185    
186    (defgeneric (setf stream-drawing-p) (drawing-p stream))
187    
188    (defgeneric stream-output-history (stream))
189    
190    (defgeneric stream-current-output-record (stream))
191    
192    (defgeneric (setf stream-current-output-record) (record stream))
193    
194    (defgeneric stream-add-output-record (stream record))
195    
196    (defgeneric stream-replay (stream &optional region))
197    
198    (defgeneric erase-output-record (record stream &optional errorp))
199    
200    (defgeneric copy-textual-output-history (window stream &optional region record))
201    
202    ;;; 16.4.3. Text Output Recording
203    (defgeneric stream-text-output-record (stream text-style))
204    
205    (defgeneric stream-close-text-output-record (stream))
206    
207    (defgeneric stream-add-character-output
208      (stream character text-style width height baseline))
209    
210    (defgeneric stream-add-string-output
211      (stream string start end text-style width height baseline))
212    
213    ;;; 16.4.4. Output Recording Utilities
214    (defgeneric invoke-with-output-recording-options
215        (stream continuation record draw))
216    
217    (defgeneric invoke-with-new-output-record (stream continuation record-type
218                                               &rest initargs
219                                               &key parent
220                                               &allow-other-keys))
221    
222    (defgeneric invoke-with-output-to-output-record
223        (stream continuation record-type
224         &rest initargs
225         &key parent
226         &allow-other-keys))
227    
228    (defgeneric make-design-from-output-record (record))
229    
230    
231    ;;;; Implementation
232    
233    ;;; Should we blow off standard-bounding-rectangle and implement the
234    ;;; bounding rectangle protocol ourselves?  Or use x1,y1 from
235    ;;; standard-bounding-rectangle as our position?
236    
237    (defclass basic-output-record (standard-bounding-rectangle output-record)
238      ((parent :initarg :parent
239               :initform nil
240               :reader output-record-parent))
241      (:documentation "Implementation class for the Basic Output Record Protocol."))
242    
243    (defmethod initialize-instance :after ((record basic-output-record)
244                                           &key (x-position 0) (y-position 0)
245                                           &rest args)
246      (declare (ignore args))
247      (with-slots (x1 y1 x2 y2) record
248        (setq x1 x-position
249              y1 y-position
250              x2 x-position
251              y2 y-position)))
252    
253    (defclass compound-output-record (basic-output-record)
254      ((x :initarg :x-position
255          :initform 0
256          :documentation "X-position of the empty record.")
257       (y :initarg :y-position
258          :initform 0
259          :documentation "Y-position of the empty record.")
260       (in-moving-p :initform nil
261                    :documentation "Is set while changing the position."))
262      (:documentation "Implementation class for output records with children."))
263    
264    ;;; 16.2.1. The Basic Output Record Protocol
265    (defmethod output-record-position ((record basic-output-record))
266      (bounding-rectangle-position record))
267    
268    (defmethod* (setf output-record-position) (nx ny (record basic-output-record))
269      (with-slots (x1 y1 x2 y2) record
270        (let ((dx (- nx x1))
271              (dy (- ny y1)))
272          (setf x1 nx  y1 ny
273                x2 (+ x2 dx)  y2 (+ y2 dy)))))
274    
275  (defmethod* (setf output-record-position) :around  (defmethod* (setf output-record-position) :around
276      (nx ny (record basic-output-record))      (nx ny (record basic-output-record))
277    (declare (ignore nx ny))    (declare (ignore nx ny))
278    (if *suppress-notify-parent*    (with-bounding-rectangle* (min-x min-y max-x max-y) record
279        (call-next-method)      (call-next-method)
280        (with-bounding-rectangle* (min-x min-y max-x max-y) record      (let ((parent (output-record-parent record)))
281          (call-next-method)        (when parent
282          (let ((parent (output-record-parent record)))          (recompute-extent-for-changed-child parent record
283            (when parent                                              min-x min-y max-x max-y)))))
             (recompute-extent-for-changed-child parent record  
                                                 min-x min-y max-x max-y))))))  
284    
285    (defmethod* (setf output-record-position) :before
286        (nx ny (record compound-output-record))
287      (with-slots (x1 y1 in-moving-p) record
288        (letf ((in-moving-p t))
289          (let ((dx (- nx x1))
290                (dy (- ny y1)))
291            (map-over-output-records
292             (lambda (child)
293               (multiple-value-bind (x y) (output-record-position child)
294                 (setf (output-record-position child)
295                       (values (+ x dx) (+ y dy)))))
296             record)))))
297    
298  (defmethod output-record-start-cursor-position ((record basic-output-record))  (defmethod output-record-start-cursor-position ((record basic-output-record))
299    (values nil nil))    (values nil nil))
# Line 249  Only those records that overlap REGION a Line 321  Only those records that overlap REGION a
321                 (replay-output-record record stream region))                 (replay-output-record record stream region))
322            (setf (stream-cursor-position stream) (values cx cy)))))))            (setf (stream-cursor-position stream) (values cx cy)))))))
323    
324  (defmethod replay-output-record ((record output-record) stream  (defmethod replay-output-record ((record compound-output-record) stream
325                                   &optional region (x-offset 0) (y-offset 0))                                   &optional region (x-offset 0) (y-offset 0))
326    (when (null region)    (when (null region)
327      (setq region +everywhere+))      (setq region +everywhere+))
# Line 257  Only those records that overlap REGION a Line 329  Only those records that overlap REGION a
329     #'replay-output-record record region x-offset y-offset     #'replay-output-record record region x-offset y-offset
330     stream region x-offset y-offset))     stream region x-offset y-offset))
331    
332  ;;; XXX ? should this be defined on output-record at all?  (defmethod output-record-hit-detection-rectangle* ((record output-record))
333  ;;; Probably not -- moore    ;; XXX DC
 (defmethod erase-output-record ((record output-record) stream  
                                 &optional (errorp t))  
   (declare (ignore stream errorp))  
   nil)  
   
 (defmethod output-record-hit-detection-rectangle*  
     ((record basic-output-record))  
334    (bounding-rectangle* record))    (bounding-rectangle* record))
335    
336  (defmethod output-record-refined-position-test ((record basic-output-record)  (defmethod output-record-refined-position-test ((record basic-output-record)
# Line 274  Only those records that overlap REGION a Line 339  Only those records that overlap REGION a
339    t)    t)
340    
341  ;;; XXX Should this only be defined on recording streams?  ;;; XXX Should this only be defined on recording streams?
342  (defmethod highlight-output-record ((record basic-output-record-mixin)  (defmethod highlight-output-record ((record output-record)
343                                      stream state)                                      stream state)
344    ;; FIXME!!! WITH-IDENTITY-TRANSFORMATION    ;; XXX DC
345    (multiple-value-bind (x1 y1 x2 y2)    ;; XXX Disable recording?
346        (output-record-hit-detection-rectangle* record)    (letf (((medium-transformation stream) +identity-transformation+))
347      (ecase state      (multiple-value-bind (x1 y1 x2 y2)
348        (:highlight          (output-record-hit-detection-rectangle* record)
349         (draw-rectangle* (sheet-medium stream) x1 y1 x2 y2        (ecase state
350                          :filled nil :ink +foreground-ink+))          (:highlight
351        (:unhighlight           (draw-rectangle* (sheet-medium stream) x1 y1 x2 y2
352         (draw-rectangle* (sheet-medium stream) x1 y1 x2 y2                            :filled nil :ink +foreground-ink+))
353                          :filled nil :ink +background-ink+)))))          (:unhighlight
354             (draw-rectangle* (sheet-medium stream) x1 y1 x2 y2
355  (defclass standard-sequence-output-record (output-record-mixin)                            :filled nil :ink +background-ink+))))))
   ((children :initform (make-array 8 :adjustable t :fill-pointer 0)  
              :reader output-record-children)))  
   
 ;;; XXX bogus for now.  
 (defclass standard-tree-output-record (standard-sequence-output-record)  
   (  
    ))  
   
 #+nil  
 (defmethod* (setf output-record-position)  
     (nx ny (record standard-sequence-output-record))  
   (with-slots (x y) record  
     (setq x nx  
           y ny)))  
356    
357  (defmethod add-output-record (child (record standard-sequence-output-record))  ;;; 16.2.2. The Output Record "Database" Protocol
358    (with-slots (children) record  (defmethod output-record-children ((record basic-output-record))
359      (vector-push-extend child children))    nil)
   (with-slots (parent) child  
     (setf parent record)))  
360    
361  (defmethod add-output-record :before (child (record output-record-mixin))  (defmethod add-output-record (child (record basic-output-record))
362    (when (zerop (output-record-count record))    (declare (ignore child))
363      (with-slots (x1 y1 x2 y2) record    (error "Cannot add a child to ~S." record))
       (setf (values x1 y1 x2 y2) (bounding-rectangle* child)))))  
364    
365  (defmethod add-output-record :after (child (record output-record))  (defmethod add-output-record :after (child (record compound-output-record))
366    (recompute-extent-for-new-child record child))    (recompute-extent-for-new-child record child))
367    
368  (defmethod delete-output-record (child (record standard-sequence-output-record)  (defmethod delete-output-record (child (record basic-output-record)
369                                   &optional (errorp t))                                   &optional (errorp t))
370    (with-slots (children) record    (declare (ignore child))
371      (let ((pos (position child children :test #'eq)))    (when errorp (error "Cannot delete a child from ~S." record)))
       (if (null pos)  
           (when errorp  
             (error "~S is not a child of ~S" child record))  
           (progn  
             (setq children (replace children children  
                                     :start1 pos  
                                     :start2 (1+ pos)))  
             (decf (fill-pointer children)))))))  
372    
373  (defmethod delete-output-record :after (child (record output-record-mixin)  (defmethod delete-output-record :after (child (record compound-output-record)
374                                          &optional (errorp t))                                                &optional (errorp t))
375    (declare (ignore errorp))    (declare (ignore errorp))
376    (with-bounding-rectangle* (x1 y1 x2 y2) child    (with-bounding-rectangle* (x1 y1 x2 y2) child
377      (recompute-extent-for-changed-child record child x1 y1 x2 y2)))      (recompute-extent-for-changed-child record child x1 y1 x2 y2)))
378    
379  (defmethod clear-output-record ((record standard-sequence-output-record))  (defmethod clear-output-record ((record basic-output-record))
380    (with-slots (children x1 y1 x2 y2) record    (error "Cannot clear ~S." record))
     (fill children nil)  
     (setf (fill-pointer children) 0)  
     (setq x2 x1  
           y2 y1)))  
381    
382  (defmethod output-record-count ((record standard-sequence-output-record))  (defmethod clear-output-record :after ((record compound-output-record))
383    (length (output-record-children record)))    (with-slots (x y x1 y1 x2 y2) record
384        (setf x1 x  y1 y
385              x2 x  y2 y)))
386    
387    (defmethod output-record-count ((record basic-output-record))
388      0)
389    
390  (defmethod map-over-output-records  (defmethod map-over-output-records
391      (function (record standard-sequence-output-record)      (function (record basic-output-record)
392         &optional (x-offset 0) (y-offset 0)
393         &rest function-args)
394      (declare (ignore function x-offset y-offset function-args))
395      nil)
396    
397    ;;; This needs to work in "most recently added last" order. Is this
398    ;;; implementation right? -- APD, 2002-06-13
399    #+nil
400    (defmethod map-over-output-records
401        (function (record compound-output-record)
402       &optional (x-offset 0) (y-offset 0)       &optional (x-offset 0) (y-offset 0)
403       &rest function-args)       &rest function-args)
404    (declare (ignore x-offset y-offset))    (declare (ignore x-offset y-offset))
405    (loop for child across (output-record-children record)    (map nil (lambda (child) (apply function child function-args))
406          do (apply function child function-args)))         (output-record-children record)))
407    
 ;;; This needs to work in "most recently added first" order, which I  
 ;;; didn't know until recently :) -- moore  
408  (defmethod map-over-output-records-containing-position  (defmethod map-over-output-records-containing-position
409      (function (record standard-sequence-output-record) x y      (function (record basic-output-record) x y
410         &optional (x-offset 0) (y-offset 0)
411         &rest function-args)
412      (declare (ignore function x y x-offset y-offset function-args))
413      nil)
414    
415    ;;; This needs to work in "most recently added first" order. Is this
416    ;;; implementation right? -- APD, 2002-06-13
417    #+nil
418    (defmethod map-over-output-records-containing-position
419        (function (record compound-output-record) x y
420       &optional (x-offset 0) (y-offset 0)       &optional (x-offset 0) (y-offset 0)
421       &rest function-args)       &rest function-args)
422    (declare (ignore x-offset y-offset))    (declare (ignore x-offset y-offset))
423    (with-slots (children) record    (map nil
424      (loop for i from (1- (length children)) downto 0         (lambda (child)
425            for child = (aref children i)           (when (and (multiple-value-bind (min-x min-y max-x max-y)
           when (and (multiple-value-bind (min-x min-y max-x max-y)  
426                          (output-record-hit-detection-rectangle* child)                          (output-record-hit-detection-rectangle* child)
427                        (and (<= min-x x max-x) (<= min-y y max-y)))                        (and (<= min-x x max-x) (<= min-y y max-y)))
428                      (output-record-refined-position-test child x y))                      (output-record-refined-position-test child x y))
429            do (apply function child function-args))))             (apply function child function-args)))
430           (output-record-children record)))
431    
432  (defmethod map-over-output-records-overlapping-region  (defmethod map-over-output-records-overlapping-region
433      (function (record standard-sequence-output-record) region      (function (record basic-output-record) region
434         &optional (x-offset 0) (y-offset 0)
435         &rest function-args)
436      (declare (ignore function region x-offset y-offset function-args))
437      nil)
438    
439    ;;; This needs to work in "most recently added last" order. Is this
440    ;;; implementation right? -- APD, 2002-06-13
441    #+nil
442    (defmethod map-over-output-records-overlapping-region
443        (function (record compound-output-record) region
444       &optional (x-offset 0) (y-offset 0)       &optional (x-offset 0) (y-offset 0)
445       &rest function-args)       &rest function-args)
446    (declare (ignore x-offset y-offset))    (declare (ignore x-offset y-offset))
447    (loop for child across (output-record-children record)    (map nil
448          do (when (region-intersects-region-p region child)         (lambda (child) (when (region-intersects-region-p region child)
449               (apply function child function-args))))                           (apply function child function-args)))
450           (output-record-children record)))
451    
452  ;;; If the child is the only child of record, the record's bounding rectangle  ;;; 16.2.3. Output Record Change Notification Protocol
 ;;; is set to the child's.  
453  (defmethod recompute-extent-for-new-child  (defmethod recompute-extent-for-new-child
454      ((record standard-sequence-output-record) child)      ((record compound-output-record) child)
455    (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2) record    (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2) record
456      (with-slots (parent children x1 y1 x2 y2) record      (with-slots (parent x1 y1 x2 y2) record
457        (if (eql 1 (length children))        (if (= 1 (length (output-record-children record)))
458            (setf (values x1 y1 x2 y2) (bounding-rectangle* child))            (setf (values x1 y1 x2 y2) (bounding-rectangle* child))
459            (with-bounding-rectangle* (x1-child y1-child x2-child y2-child) child            (with-bounding-rectangle* (x1-child y1-child x2-child y2-child) child
460              (minf x1 x1-child)              (minf x1 x1-child)
# Line 396  Only those records that overlap REGION a Line 465  Only those records that overlap REGION a
465          (recompute-extent-for-changed-child parent record          (recompute-extent-for-changed-child parent record
466                                              old-x1 old-y1 old-x2 old-y2)))))                                              old-x1 old-y1 old-x2 old-y2)))))
467    
468  (defmethod recompute-extent-for-changed-child :around  (defmethod %tree-recompute-extent* ((record compound-output-record))
469      ((record basic-output-record-mixin) child    ;; Internal helper function
      old-min-x old-min-y old-max-x old-max-y)  
   (declare (ignore child old-min-x old-min-y old-max-x old-max-y))  
   (let ((old-rectangle (multiple-value-call #'make-bounding-rectangle  
                          (bounding-rectangle* record))))  
     (call-next-method)  
     (with-slots (parent x1 y1 x2 y2) record  
       (when (and parent (not (region-equal old-rectangle record)))  
         (recompute-extent-for-changed-child parent record x1 y1 x2 y2)))))  
   
 ;; Internal helper function  
 (defmethod %tree-recompute-extent* ((record output-record))  
470    (let ((new-x1 0)    (let ((new-x1 0)
471          (new-y1 0)          (new-y1 0)
472          (new-x2 0)          (new-x2 0)
473          (new-y2 0)          (new-y2 0)
474          (first-time t))          (first-time t))
475      (map-over-output-records      (map-over-output-records
476       #'(lambda (child)       (lambda (child)
477           (if first-time         (if first-time
478               (progn             (progn
479                 (setf (values new-x1 new-y1 new-x2 new-y2)               (multiple-value-setq (new-x1 new-y1 new-x2 new-y2)
480                       (bounding-rectangle* child))                 (bounding-rectangle* child))
481                 (setq first-time nil))               (setq first-time nil))
482               (with-bounding-rectangle* (cx1 cy1 cx2 cy2) child             (with-bounding-rectangle* (cx1 cy1 cx2 cy2) child
483                 (minf new-x1 cx1)               (minf new-x1 cx1)
484                 (minf new-y1 cy1)               (minf new-y1 cy1)
485                 (maxf new-x2 cx2)               (maxf new-x2 cx2)
486                 (maxf new-y2 cy2))))               (maxf new-y2 cy2))))
487       record)       record)
     ;; If we don't have any children, collapse the bbox to the min point.  
488      (if first-time      (if first-time
489          (multiple-value-bind (x1 y1)          (with-slots (x y) record
490              (output-record-position record)            (values x y x y))
           (values x1 y1 x1 y1))  
491          (values new-x1 new-y1 new-x2 new-y2))))          (values new-x1 new-y1 new-x2 new-y2))))
492    
493  (defmethod recompute-extent-for-changed-child  (defmethod recompute-extent-for-changed-child
494      ((record output-record-mixin) changed-child      ((record compound-output-record) changed-child
495       old-min-x old-min-y old-max-x old-max-y)       old-min-x old-min-y old-max-x old-max-y)
496    ;; If the child's old and new bbox lies entirely within the record's bbox    ;; If the child's old and new bbox lies entirely within the record's bbox
497    ;; then no change need be made to the record's bbox.  Otherwise, if some part    ;; then no change need be made to the record's bbox.  Otherwise, if some part
# Line 444  Only those records that overlap REGION a Line 500  Only those records that overlap REGION a
500    (with-slots (x1 y1 x2 y2) record    (with-slots (x1 y1 x2 y2) record
501      (with-bounding-rectangle* (child-x1 child-y1 child-x2 child-y2)      (with-bounding-rectangle* (child-x1 child-y1 child-x2 child-y2)
502          changed-child          changed-child
503        (unless (and (> x1 old-min-x)        (unless (and (> x1 old-min-x) (> x1 child-x1)
504                     (> y1 old-min-y)                     (> y1 old-min-y) (> y1 child-y1)
505                     (< x2 old-max-x)                     (< x2 old-max-x) (< x2 child-x2)
506                     (< y2 old-max-y)                     (< y2 old-max-y) (< y2 child-y2))
                    (> x1 child-x1)  
                    (> y1 child-y1)  
                    (< x2 child-x2)  
                    (< y2 child-y2))  
507          ;; Don't know if changed-child has been deleted or what, so go through          ;; Don't know if changed-child has been deleted or what, so go through
508          ;; all the children and construct the updated bbox.          ;; all the children and construct the updated bbox.
509          (setf (values x1 y1 x2 y2) (%tree-recompute-extent* record))          (setf (values x1 y1 x2 y2) (%tree-recompute-extent* record))
510          nil))))          nil))))
511    
512  (defmethod tree-recompute-extent ((record output-record-mixin))  (defmethod recompute-extent-for-changed-child :around
513        ((record compound-output-record) child
514         old-min-x old-min-y old-max-x old-max-y)
515      (declare (ignore child old-min-x old-min-y old-max-x old-max-y))
516      (unless (slot-value record 'in-moving-p)
517        (let ((old-rectangle (bounding-rectangle record)))
518          (call-next-method)
519          (with-slots (parent x1 y1 x2 y2) record
520            (when (and parent (not (region-equal old-rectangle record)))
521              (recompute-extent-for-changed-child parent record x1 y1 x2 y2))))))
522    
523    (defmethod tree-recompute-extent ((record compound-output-record))
524    (with-slots (x1 y1 x2 y2) record    (with-slots (x1 y1 x2 y2) record
525      (setf (values x1 y1 x2 y2) (%tree-recompute-extent* record))      (setf (values x1 y1 x2 y2) (%tree-recompute-extent* record))
526      nil))      nil))
527    
528    (defmethod tree-recompute-extent :around ((record compound-output-record))
529  (defmethod tree-recompute-extent :around ((record output-record))    (let ((old-rectangle (bounding-rectangle record))) ; XXX Is it mutable?
   (let ((old-rectangle (multiple-value-call #'make-bounding-rectangle  
                          (bounding-rectangle* record))))  
530      (call-next-method)      (call-next-method)
531      (with-slots (parent x1 y1 x2 y2) record      (with-slots (parent x1 y1 x2 y2) record
532        (when (and parent (not (region-equal old-rectangle record)))        (when (and parent (not (region-equal old-rectangle record)))
533          (recompute-extent-for-changed-child parent record x1 y1 x2 y2)))))          (recompute-extent-for-changed-child parent record x1 y1 x2 y2)))))
534    
535    ;;; 16.3.1. Standard output record classes
 ;;; Graphics recording classes  
   
 (defclass graphics-displayed-output-record (displayed-output-record)  
   ())  
   
 (defclass graphics-displayed-output-record-mixin  
     (displayed-output-record-mixin graphics-displayed-output-record)  
   ((clip :initarg :clipping-region  
          :documentation "Clipping region in user coordinates.")  
    (transform :initarg :transformation)  
    (line-style :initarg :line-style)  
    (text-style :initarg :text-style)  
    ))  
   
 (defun graphics-displayed-output-record-p (x)  
   (typep x 'graphics-displayed-output-record))  
536    
537    (defclass standard-sequence-output-record (compound-output-record)
538  ;;; stream-output-history-mixin class    ((children :initform (make-array 8 :adjustable t :fill-pointer 0)
539                 :reader output-record-children)))
 (defclass stream-output-history-mixin ()  
   ())  
   
 (defclass standard-sequence-output-history  
     (standard-sequence-output-record stream-output-history-mixin)  
   ())  
   
 (defclass standard-tree-output-history  
     (standard-tree-output-record stream-output-history-mixin)  
   ())  
   
   
 ;;; Output-Recording-Stream class  
   
 (defclass output-recording-stream ()  
   ())  
   
 (defun output-recording-stream-p (x)  
   (typep x 'output-recording-stream))  
   
 (defclass standard-output-recording-stream (output-recording-stream)  
   ((recording-p :initform t :reader stream-recording-p)  
    (drawing-p :initform t :accessor stream-drawing-p)  
    (output-history :initform (make-instance 'standard-tree-output-history)  
                    :reader stream-output-history)  
    (current-output-record :accessor stream-current-output-record)  
    (current-text-output-record :initform nil  
                                :accessor stream-current-text-output-record)  
    (local-record-p :initform t  
                    :documentation "This flag is used for dealing with streams outputting strings char-by-char.")))  
   
 ;;; 16.4.1 The Output Recording Stream Protocol  
 (defgeneric stream-recording-p (stream))  
   
 (defgeneric (setf stream-recording-p) (recording-p stream))  
   
 (defgeneric stream-drawing-p (stream))  
   
 (defgeneric (setf stream-drawing-p) (drawing-p stream))  
   
 (defgeneric stream-output-history (stream))  
   
 (defgeneric stream-current-output-record (stream))  
   
 (defgeneric (setf stream-current-output-record) (record stream))  
   
 (defgeneric stream-add-output-record (stream record))  
   
 (defgeneric stream-replay (stream &optional region))  
   
 (defgeneric erase-output-record (record stream &optional (errorp t)))  
   
 (defgeneric copy-textual-output-history (window stream &optional region record))  
   
 (defmethod (setf stream-recording-p)  
     (recording-p (stream standard-output-recording-stream))  
   (let ((old-val (slot-value stream 'recording-p)))  
     (setf (slot-value stream 'recording-p) recording-p)  
     (when (not (eql old-val recording-p))  
       (stream-close-text-output-record stream))  
     recording-p))  
   
 ;;; 16.4.3 Text Output Recording  
   
 (defgeneric stream-text-output-record (stream text-style))  
   
 (defgeneric stream-close-text-output-record (stream))  
   
 (defgeneric stream-add-character-output  
   (stream character text-style width height baseline))  
   
 (defgeneric stream-add-string-output  
   (stream string start end text-style width height baseline))  
   
 ;;; Methods  
 (defmethod initialize-instance :after ((stream output-recording-stream) &rest args)  
   (declare (ignore args))  
   (setf (stream-current-output-record stream) (stream-output-history stream)))  
   
 (defmethod stream-add-output-record ((stream output-recording-stream) record)  
   (add-output-record record (stream-current-output-record stream)))  
   
 (defmethod stream-replay ((stream output-recording-stream) &optional region)  
   (replay (stream-output-history stream) stream region))  
   
 (defmacro with-output-recording-options ((stream  
                                           &key (record nil record-supplied-p)  
                                                (draw nil draw-supplied-p))  
                                          &body body)  
   (declare (type symbol stream))  
   (when (eq stream 't)  
     (setq stream '*standard-output*))  
   (let ((continuation-name (gensym "WITH-OUTPUT-RECORDING-OPTIONS")))  
     `(flet ((,continuation-name  (,stream) ,@body))  
        (declare (dynamic-extent #',continuation-name))  
        (invoke-with-output-recording-options ,stream  
                                              #',continuation-name  
                                              ,(if record-supplied-p  
                                                   record  
                                                   `(stream-recording-p  
                                                     ,stream))  
                                              ,(if draw-supplied-p  
                                                   draw  
                                                   `(stream-drawing-p  
                                                     ,stream))))))  
   
   
 (defmethod invoke-with-output-recording-options  
   ((stream output-recording-stream) continuation record draw)  
   "Calls CONTINUATION on STREAM enabling or disabling recording and drawing  
 according to the flags RECORD and DRAW."  
   (letf (((stream-recording-p stream) record)  
          ((stream-drawing-p stream) draw))  
     (funcall continuation stream)))  
   
 (defmacro with-new-output-record ((stream  
                                    &optional  
                                    (record-type 'standard-sequence-output-record)  
                                    (record nil record-supplied-p)  
                                    &rest initargs)  
                                   &body body)  
   "Creates a new output record of type RECORD-TYPE and then captures  
 the output of BODY into the new output record, and inserts the new  
 record into the current \"open\" output record assotiated with STREAM.  
     If RECORD is supplied, it is the name of a variable that will be  
 lexically bound to the new output record inside the body. INITARGS are  
 CLOS initargs that are passed to MAKE-INSTANCE when the new output  
 record is created.  
     It returns the created output record.  
     The STREAM argument is a symbol that is bound to an output  
 recording stream. If it is T, *STANDARD-OUTPUT* is used."  
   (declare (type symbol stream record))  
   (when (eq stream 't)  
     (setq stream '*standard-output*))  
   (unless record-supplied-p  
     (setq record (gensym)))  
   `(invoke-with-new-output-record  
     ,stream  
     #'(lambda (,stream ,record)  
         (declare (ignorable ,stream ,record))  
         ,@body)  
     ',record-type  
     ,@initargs))  
   
 (defmethod invoke-with-new-output-record ((stream output-recording-stream)  
                                           continuation record-type  
                                           &rest initargs  
                                           &key parent  
                                           &allow-other-keys)  
   (stream-close-text-output-record stream)  
   (unless parent  
     (setq parent (stream-current-output-record stream)))  
   (let ((new-record (apply #'make-instance record-type :parent parent initargs)))  
     (letf (((stream-current-output-record stream) new-record))  
       ;; Should we switch on recording? -- APD  
       (funcall continuation stream new-record)  
       (finish-output stream))  
     (stream-add-output-record stream new-record)  
     new-record))  
   
 (defmacro with-output-to-output-record  
     ((stream  
       &optional  
       (record-type 'standard-sequence-output-record)  
       (record nil record-supplied-p)  
       &rest initargs)  
      &body body)  
   "Creates a new output record of type RECORD-TYPE and then captures  
 the output of BODY into the new output record. The cursor position of  
 STREAM is initially bound to (0,0)  
     If RECORD is supplied, it is the name of a variable that will be  
 lexically bound to the new output record inside the body. INITARGS are  
 CLOS initargs that are passed to MAKE-INSTANCE when the new output  
 record is created.  
     It returns the created output record.  
     The STREAM argument is a symbol that is bound to an output  
 recording stream. If it is T, *STANDARD-OUTPUT* is used."  
   (when (eq stream 't)  
     (setq stream '*standard-output*))  
   (check-type stream symbol)  
   (unless record-supplied-p (setq record (gensym "RECORD")))  
   `(invoke-with-output-to-output-record  
     ,stream  
     #'(lambda (,stream ,record)  
         (declare (ignorable ,stream ,record))  
         ,@body)  
     ',record-type  
     ,@initargs))  
540    
541  (defmethod invoke-with-output-to-output-record  (defmethod add-output-record (child (record standard-sequence-output-record))
542      ((stream output-recording-stream)    (with-slots (children) record
543       continuation record-type      (vector-push-extend child children))
544       &rest initargs    (with-slots (parent) child ; FIXME!!!
545       &key parent      (setf parent record)))
      &allow-other-keys)  
   (stream-close-text-output-record stream)  
   (unless parent (setq parent (stream-current-output-record stream)))  
   (let ((new-record (apply #'make-instance record-type  
                            :parent parent initargs)))  
     (with-output-recording-options (stream :record t :draw nil)  
       (multiple-value-bind (cx cy)  
           (stream-cursor-position stream)  
         (unwind-protect  
              (letf (((stream-current-output-record stream) new-record))  
                (setf (stream-cursor-position stream) (values 0 0))  
                (funcall continuation stream new-record)  
                (finish-output stream))  
           (setf (stream-cursor-position stream) (values cx cy)))))  
     new-record))  
546    
547  (defmethod scroll-vertical :around ((stream output-recording-stream) dy)  #+nil
548    (declare (ignore dy))  (defmethod add-output-record :before (child (record compound-output-record))
549    (with-output-recording-options (stream :record nil)    (when (zerop (output-record-count record))
550      (declare (ignore stream))      (with-slots (x1 y1 x2 y2) record
551      (call-next-method)))        (setf (values x1 y1 x2 y2) (bounding-rectangle* child)))))
552    
553  (defmethod scroll-horizontal :around ((stream output-recording-stream) dx)  (defmethod delete-output-record (child (record standard-sequence-output-record)
554    (declare (ignore dx))                                   &optional (errorp t))
555    (with-output-recording-options (stream :record nil)    (with-slots (children) record
556      (declare (ignore stream))      (let ((pos (position child children :test #'eq)))
557      (call-next-method)))        (if (null pos)
558              (when errorp
559                (error "~S is not a child of ~S" child record))
560              (progn
561                (setq children (replace children children
562                                        :start1 pos
563                                        :start2 (1+ pos)))
564                (decf (fill-pointer children)))))))
565    
566  (defmethod handle-repaint ((stream output-recording-stream) region)  (defmethod clear-output-record ((record standard-sequence-output-record))
567    (stream-replay stream region))    (with-slots (children) record
568        (fill children nil)
569        (setf (fill-pointer children) 0)))
570    
571  #|  (defmethod output-record-count ((record standard-sequence-output-record))
572  (defmethod handle-event :after ((stream output-recording-stream) (event pointer-button-press-event))    (length (output-record-children record)))
   (highlight-output-record (stream-current-output-record stream) stream :highlight))  
573    
574  (defmethod handle-event :before ((stream output-recording-stream) (event pointer-button-release-event))  (defmethod map-over-output-records
575    (highlight-output-record (stream-current-output-record stream) stream :unhighlight))      (function (record standard-sequence-output-record)
576  |#       &optional (x-offset 0) (y-offset 0)
577         &rest function-args)
578      "Applies FUNCTION to all children in the order they were added."
579      (declare (ignore x-offset y-offset))
580      (loop with children = (output-record-children record)
581         for child across children
582         do (apply function child function-args)))
583    
584    (defmethod map-over-output-records-containing-position
585  ;;; Graphics and text recording classes      (function (record standard-sequence-output-record) x y
586         &optional (x-offset 0) (y-offset 0)
587         &rest function-args)
588      "Applies FUNCTION to children, containing (X,Y), in the reversed
589    order they were added."
590      (declare (ignore x-offset y-offset))
591      (loop with children = (output-record-children record)
592         for i from (1- (length children)) downto 0
593         for child = (aref children i)
594         when (and (multiple-value-bind (min-x min-y max-x max-y)
595                       (output-record-hit-detection-rectangle* child)
596                     (and (<= min-x x max-x) (<= min-y y max-y)))
597                   (output-record-refined-position-test child x y))
598         do (apply function child function-args)))
599    
600    (defmethod map-over-output-records-overlapping-region
601        (function (record standard-sequence-output-record) region
602         &optional (x-offset 0) (y-offset 0)
603         &rest function-args)
604      "Applies FUNCTION to children, overlapping REGION, in the order they
605    were added."
606      (declare (ignore x-offset y-offset))
607      (loop with children = (output-record-children record)
608         for child across children
609         when (region-intersects-region-p region child)
610         do (apply function child function-args)))
611    
612  (eval-when (:compile-toplevel :load-toplevel :execute)  ;;; XXX bogus for now.
613    (defclass standard-tree-output-record (standard-sequence-output-record)
614      (
615       ))
616    
617    (defun compute-class-vars (names)  ;;; 16.3.2. Graphics Displayed Output Records
618      (cons (list 'stream :initarg :stream)  (defclass standard-displayed-output-record (basic-output-record
619            (loop for name in names                                              displayed-output-record)
620                  collecting (list name :initarg (intern (symbol-name name)    ((ink :initarg :ink :reader displayed-output-record-ink)
621                                                         :keyword)))))     (initial-x1 :initarg :initial-x1)
622       (initial-y1 :initarg :initial-y1))
623      (:documentation "Implementation class for DISPLAYED-OUTPUT-RECORD."))
624    
625    (defun compute-arg-list (names)  (defclass standard-graphics-displayed-output-record
626      (loop for name in names      (standard-displayed-output-record graphics-displayed-output-record)
627            nconcing (list (intern (symbol-name name) :keyword) name)))    ((clip :initarg :clipping-region
628    )           :documentation "Clipping region in user coordinates.")
629       (transform :initarg :transformation)
630       (line-style :initarg :line-style)
631       (text-style :initarg :text-style)))
632    
633  (defmacro def-grecording (name (&rest args) &body body)  (defmacro def-grecording (name (&rest args) &body body)
634    (let ((method-name (intern (format nil "MEDIUM-~A*" name)))    (let ((method-name (intern (format nil "MEDIUM-~A*" name)))
635          (class-name (intern (format nil "~A-OUTPUT-RECORD" name)))          (class-name (intern (format nil "~A-OUTPUT-RECORD" name)))
636          (medium (gensym "MEDIUM"))          (medium (gensym "MEDIUM"))
637          (border 'border))          (border 'border)
638            (class-vars `((stream :initarg :stream)
639                          ,@(loop for arg in args
640                               collect `(,arg
641                                         :initarg ,(intern (symbol-name arg)
642                                                           :keyword)))))
643            (arg-list (loop for arg in args
644                         nconc `(,(intern (symbol-name arg) :keyword) ,arg))))
645      `(progn      `(progn
646         (defclass ,class-name (graphics-displayed-output-record-mixin)         (defclass ,class-name (standard-graphics-displayed-output-record)
647           ,(compute-class-vars args))           ,class-vars)
648         (defmethod initialize-instance :after ((graphic ,class-name) &rest args)         (defmethod initialize-instance :after ((graphic ,class-name) &rest args)
649           (declare (ignore args))           (declare (ignore args))
650           (with-slots (x y x1 y1 x2 y2 initial-x1 initial-y1           (with-slots (x1 y1 x2 y2 initial-x1 initial-y1
651                        stream ink clipping-region transform                        stream ink clipping-region transform
652                        line-style text-style                        line-style text-style
653                        ,@args) graphic                        ,@args) graphic
# Line 760  recording stream. If it is T, *STANDARD- Line 656  recording stream. If it is T, *STANDARD-
656                               2)))                               2)))
657               (declare (ignorable ,border))               (declare (ignorable ,border))
658               (multiple-value-setq (x1 y1 x2 y2) (progn ,@body)))               (multiple-value-setq (x1 y1 x2 y2) (progn ,@body)))
659             (setf x x1             (setf initial-x1 x1
                  y y1  
                  initial-x1 x1  
660                   initial-y1 y1)))                   initial-y1 y1)))
661         (defmethod ,method-name :around ((stream output-recording-stream) ,@args)         (defmethod ,method-name :around ((stream output-recording-stream) ,@args)
662           (with-sheet-medium (medium stream)           (with-sheet-medium (medium stream)
# Line 774  recording stream. If it is T, *STANDARD- Line 668  recording stream. If it is T, *STANDARD-
668                               :transformation (medium-transformation medium)                               :transformation (medium-transformation medium)
669                               :line-style (medium-line-style medium)                               :line-style (medium-line-style medium)
670                               :text-style (medium-text-style medium)                               :text-style (medium-text-style medium)
671                               ,@(compute-arg-list args))))                               ,@arg-list)))
672                 (stream-add-output-record stream record)))                 (stream-add-output-record stream record)))
673             (when (stream-drawing-p stream)             (when (stream-drawing-p stream)
674               (call-next-method))))               (call-next-method))))
675         (defmethod replay-output-record ((record ,class-name) stream         (defmethod replay-output-record ((record ,class-name) stream
676                                          &optional (region +everywhere+)                                          &optional (region +everywhere+)
677                                          (x-offset 0) (y-offset 0))                                          (x-offset 0) (y-offset 0))
678           (with-slots (x y initial-x1 initial-y1           (declare (ignore x-offset y-offset))
679             (with-slots (x1 y1 initial-x1 initial-y1
680                        ink clip transform line-style text-style ,@args) record                        ink clip transform line-style text-style ,@args) record
681             (let ((transformation (compose-translation-with-transformation             (let ((transformation (compose-translation-with-transformation
682                                    transform                                    transform
683                                    (+ (- x initial-x1) x-offset)                                    (- x1 initial-x1)
684                                    (+ (- y initial-y1) y-offset)))                                    (- y1 initial-y1)))
685                   (,medium (sheet-medium stream))                   (,medium (sheet-medium stream))
686                   ;; is sheet a sheet-with-medium-mixin? --GB                   ;; is sheet a sheet-with-medium-mixin? --GB
687                   )                   )
# Line 918  recording stream. If it is T, *STANDARD- Line 813  recording stream. If it is T, *STANDARD-
813                      bottom (+ point-y (ceiling height 2)))))                      bottom (+ point-y (ceiling height 2)))))
814     (values left top right bottom)))     (values left top right bottom)))
815    
816    ;;; 16.3.3. Text Displayed Output Record
 ;;; Text recording class  
   
 (defclass text-displayed-output-record (displayed-output-record)  
   ())  
817    
818  (defclass text-displayed-output-record-mixin  (defclass standard-text-displayed-output-record
819      (text-displayed-output-record displayed-output-record-mixin)      (text-displayed-output-record standard-displayed-output-record)
820    ((strings :initform nil)    ((strings :initform nil
821                :documentation "A list of (start-x text-style substring)"
822                ;; XXX Turn into a class
823                )
824     (baseline :initform 0)     (baseline :initform 0)
825     (width :initform 0)     (width :initform 0)
826     (max-height :initform 0)     (max-height :initform 0)
# Line 937  recording stream. If it is T, *STANDARD- Line 831  recording stream. If it is T, *STANDARD-
831     (wrapped :initform nil     (wrapped :initform nil
832              :accessor text-record-wrapped)))              :accessor text-record-wrapped)))
833    
834  (defun text-displayed-output-record-p (x)  (defmethod print-object ((self standard-text-displayed-output-record) stream)
   (typep x 'text-displayed-output-record))  
   
 (defmethod print-object ((self text-displayed-output-record-mixin) stream)  
835    (print-unreadable-object (self stream :type t :identity t)    (print-unreadable-object (self stream :type t :identity t)
836      (if (slot-boundp self 'start-x)      (if (slot-boundp self 'start-x)
837          (with-slots (start-x start-y strings) self          (with-slots (start-x start-y strings) self
838            (format stream "~D,~D ~S" start-x start-y (mapcar #'third strings)))            (format stream "~D,~D ~S" start-x start-y (mapcar #'third strings)))
839        (format stream "empty"))))        (format stream "empty"))))
840    
 (defgeneric add-character-output-to-text-record  
   (text-record character text-style width height baseline))  
 (defgeneric add-string-output-to-text-record  
   (text-record string start end text-style width height baseline))  
 (defgeneric text-displayed-output-record-string (text-record))  
   
 ;;; Methods  
 (defmethod tree-recompute-extent  
     ((text-record text-displayed-output-record-mixin))  
   (with-slots (parent x y  
                       x1 y1 x2 y2 width max-height) text-record  
               (setq x1 (coordinate x)  
                     y1 (coordinate y)  
                     x2 (coordinate (+ x width))  
                     y2 (coordinate (+ y max-height)))))  
   
841  (defmethod* (setf output-record-position) :before  (defmethod* (setf output-record-position) :before
842      (nx ny (record text-displayed-output-record-mixin))      (nx ny (record standard-text-displayed-output-record))
843    (with-slots (x1 y1 x2 y2 x y start-x start-y end-x end-y) record    (with-slots (x1 y1 start-x start-y end-x end-y) record
844      (let ((dx (- nx x))      (let ((dx (- nx x1))
845            (dy (- ny y)))            (dy (- ny y1)))
846        (incf start-x dx)        (incf start-x dx)
847        (incf start-y dy)        (incf start-y dy)
848        (incf end-x dx)        (incf end-x dx)
849        (incf end-y dy))))        (incf end-y dy))))
850    
851  (defmethod add-character-output-to-text-record ((text-record text-displayed-output-record-mixin)  (defmethod replay-output-record ((record standard-text-displayed-output-record)
                                                 character text-style char-width height  
                                                 new-baseline)  
   (with-slots (strings baseline width max-height start-y end-x end-y) text-record  
     (if (and strings (eq (second (first (last strings))) text-style))  
         (vector-push-extend character (third (first (last strings))))  
       (setq strings (nconc strings (list (list end-x text-style (make-array 1 :initial-element character :element-type 'character :adjustable t :fill-pointer t))))))  
     (setq baseline (max baseline new-baseline)  
           end-x (+ end-x char-width)  
           max-height (max max-height height)  
           end-y (max end-y (+ start-y max-height))  
           width (+ width char-width)))  
   (tree-recompute-extent text-record))  
   
 (defmethod add-string-output-to-text-record ((text-record text-displayed-output-record-mixin)  
                                              string start end text-style string-width height  
                                              new-baseline)  
   (if end  
       (setq end (min end (1- (length string))))  
       (setq end (1- (length string))))  
   (let ((length (max 0 (- (1+ end) start))))  
     (cond  
      ((= length 1)  
       (add-character-output-to-text-record text-record (aref string start) text-style string-width height new-baseline))  
      (t  
       (setq string (make-array length :displaced-to string  
                                :displaced-index-offset start  
                                :element-type (array-element-type string)))  
       (with-slots (strings baseline width max-height start-y end-x end-y) text-record  
         (setq baseline (max baseline new-baseline)  
               strings (nconc strings  
                              (list (list end-x text-style  
                                          (make-array (length string)  
                                                      :initial-contents string  
                                                      :element-type 'character  
                                                      :adjustable t  
                                                      :fill-pointer t))))  
               end-x (+ end-x string-width)  
               max-height (max max-height height)  
               end-y (max end-y (+ start-y max-height))  
               width (+ width string-width)))  
       (tree-recompute-extent text-record)))))  
   
 (defmethod replay-output-record ((record text-displayed-output-record-mixin)  
852                                   stream                                   stream
853                                   &optional region (x-offset 0) (y-offset 0))                                   &optional region (x-offset 0) (y-offset 0))
854    (declare (ignore region))    (declare (ignore region x-offset y-offset))
855    (with-slots (strings baseline max-height start-x start-y wrapped    (with-slots (strings baseline max-height start-x start-y wrapped
856                 x y x1 y1 initial-x1 initial-y1) record                 x1 y1 initial-x1 initial-y1) record
857      (let ((old-medium (sheet-medium stream))      (let ((old-medium (sheet-medium stream))
858            (new-medium (make-medium (port stream) stream)))            (new-medium (make-medium (port stream) stream)))
859        (unwind-protect        (unwind-protect
860             (progn             (progn
861               (setf (%sheet-medium stream) new-medium) ;is sheet a sheet-with-medium-mixin? --GB               (setf (%sheet-medium stream) new-medium) ;is sheet a sheet-with-medium-mixin? --GB
862               (setf (%medium-sheet new-medium) stream) ;is medium a basic medium?               (setf (%medium-sheet new-medium) stream) ;is medium a basic medium?
              (setf (medium-transformation new-medium)  
                    (make-translation-transformation  
                     x-offset  
                     y-offset))  
863    
864               (setf (stream-cursor-position stream) (values start-x start-y))               (setf (stream-cursor-position stream) (values start-x start-y))
865               (letf (((slot-value stream 'baseline) baseline))               (letf (((slot-value stream 'baseline) baseline))
# Line 1055  recording stream. If it is T, *STANDARD- Line 883  recording stream. If it is T, *STANDARD-
883          (setf (%sheet-medium stream) old-medium))))) ;is sheet a sheet-with-medium-mixin? --GB          (setf (%sheet-medium stream) old-medium))))) ;is sheet a sheet-with-medium-mixin? --GB
884    
885  (defmethod output-record-start-cursor-position  (defmethod output-record-start-cursor-position
886      ((record text-displayed-output-record-mixin))      ((record standard-text-displayed-output-record))
887    (with-slots (start-x start-y) record    (with-slots (start-x start-y) record
888      (values start-x start-y)))      (values start-x start-y)))
889    
890  (defmethod output-record-end-cursor-position  (defmethod output-record-end-cursor-position
891      ((record text-displayed-output-record-mixin))      ((record standard-text-displayed-output-record))
892    (with-slots (end-x end-y) record    (with-slots (end-x end-y) record
893      (values end-x end-y)))      (values end-x end-y)))
894    
895    (defmethod tree-recompute-extent
896        ((text-record standard-text-displayed-output-record))
897      (with-slots (parent x1 y1 x2 y2 width max-height) text-record
898                  (setq x2 (coordinate (+ x1 width))
899                        y2 (coordinate (+ y1 max-height)))))
900    
901    (defmethod add-character-output-to-text-record
902        ((text-record standard-text-displayed-output-record)
903         character text-style char-width height new-baseline)
904      (with-slots (strings baseline width max-height start-y end-x end-y)
905          text-record
906        (if (and strings (eq (second (first (last strings))) text-style))
907            (vector-push-extend character (third (first (last strings))))
908            (setq strings (nconc strings
909                                 `((,end-x
910                                    ,text-style
911                                    ,(make-array 1 :initial-element character
912                                                 :element-type 'character
913                                                 :adjustable t
914                                                 :fill-pointer t))))))
915        (setq baseline (max baseline new-baseline)
916              end-x (+ end-x char-width)
917              max-height (max max-height height)
918              end-y (max end-y (+ start-y max-height))
919              width (+ width char-width)))
920      (tree-recompute-extent text-record))
921    
922    (defmethod add-string-output-to-text-record
923        ((text-record standard-text-displayed-output-record)
924         string start end text-style string-width height new-baseline)
925      (if end
926          (setq end (min end (length string)))
927          (setq end (length string)))
928      (let ((length (max 0 (- end start))))
929        (cond
930         ((= length 1)
931          (add-character-output-to-text-record text-record
932                                               (aref string start)
933                                               text-style
934                                               string-width height new-baseline))
935         (t
936          (setq string (make-array length :displaced-to string ; XXX
937                                   :displaced-index-offset start
938                                   :element-type (array-element-type string)))
939          (with-slots (strings baseline width max-height start-y end-x end-y)
940              text-record
941            (setq baseline (max baseline new-baseline)
942                  strings (nconc strings
943                                 (list (list end-x text-style
944                                             (make-array (length string)
945                                                         :initial-contents string
946                                                         :element-type 'character
947                                                         :adjustable t
948                                                         :fill-pointer t))))
949                  end-x (+ end-x string-width)
950                  max-height (max max-height height)
951                  end-y (max end-y (+ start-y max-height))
952                  width (+ width string-width)))
953          (tree-recompute-extent text-record)))))
954    
955  (defmethod text-displayed-output-record-string  (defmethod text-displayed-output-record-string
956      ((record text-displayed-output-record-mixin))      ((record standard-text-displayed-output-record))
957    (with-slots (strings) record    (with-output-to-string (result)
958      (loop for result = ""      (with-slots (strings) record
959            for s in strings        (loop for (nil nil substring) in strings
960            do (setq result (concatenate 'string result (third s)))           do (write-string substring result)))))
              finally (return result))))  
961    
962    ;;; 16.3.4. Top-Level Output Records
963  (defclass stream-text-record (text-displayed-output-record-mixin)  (defclass stream-output-history-mixin ()
964      ())
965    
966    (defclass standard-sequence-output-history
967        (standard-sequence-output-record stream-output-history-mixin)
968      ())
969    
970    (defclass standard-tree-output-history
971        (standard-tree-output-record stream-output-history-mixin)
972    ())    ())
973    
974  ;;; Methods for text output to output recording streams  ;;; 16.4. Output Recording Streams
975  (defmethod stream-text-output-record ((stream standard-output-recording-stream) text-style)  (defclass standard-output-recording-stream (output-recording-stream)
976      ((recording-p :initform t :reader stream-recording-p)
977       (drawing-p :initform t :accessor stream-drawing-p)
978       (output-history :initform (make-instance 'standard-tree-output-history)
979                       :reader stream-output-history)
980       (current-output-record :accessor stream-current-output-record)
981       (current-text-output-record :initform nil
982                                   :accessor stream-current-text-output-record)
983       (local-record-p :initform t
984                       :documentation "This flag is used for dealing with streams outputting strings char-by-char.")))
985    
986    (defmethod initialize-instance :after
987        ((stream standard-output-recording-stream) &rest args)
988      (declare (ignore args))
989      (setf (stream-current-output-record stream) (stream-output-history stream)))
990    
991    ;;; 16.4.1 The Output Recording Stream Protocol
992    (defmethod (setf stream-recording-p)
993        (recording-p (stream standard-output-recording-stream))
994      (let ((old-val (slot-value stream 'recording-p)))
995        (setf (slot-value stream 'recording-p) recording-p)
996        (when (not (eq old-val recording-p))
997          (stream-close-text-output-record stream))
998        recording-p))
999    
1000    (defmethod stream-add-output-record
1001        ((stream standard-output-recording-stream) record)
1002      (add-output-record record (stream-current-output-record stream)))
1003    
1004    (defmethod stream-replay
1005        ((stream standard-output-recording-stream) &optional region)
1006      (replay (stream-output-history stream) stream region))
1007    
1008    (defmethod erase-output-record (record (stream standard-output-recording-stream)
1009                                    &optional (errorp t))
1010      (letf (((stream-recording-p stream)  nil))
1011        (let ((region (bounding-rectangle record)))
1012          (with-bounding-rectangle* (x1 y1 x2 y2) region
1013            (delete-output-record record (stream-output-history stream) errorp)
1014            ;; FIXME: if RECORD is not a child of RECORD, the following
1015            ;; operations should not be done
1016            (draw-rectangle* stream x1 y1 x2 y2 :ink +background-ink+)
1017            (stream-replay stream region)))))
1018    
1019    (defun copy-textual-output-history (window stream &optional region record)
1020      ;; FIXME
1021      (declare (ignore window stream region record))
1022      (error "Not implemented."))
1023    
1024    ;;; 16.4.3. Text Output Recording
1025    (defclass stream-text-record (standard-text-displayed-output-record)
1026      ()) ; XXX Is it necessary? -- APD, 2002-06-13.
1027    
1028    (defmethod stream-text-output-record
1029        ((stream standard-output-recording-stream) text-style)
1030    (declare (ignore text-style))    (declare (ignore text-style))
1031    (let ((record (stream-current-text-output-record stream)))    (let ((record (stream-current-text-output-record stream)))
1032      (unless record      (unless record
# Line 1095  recording stream. If it is T, *STANDARD- Line 1044  recording stream. If it is T, *STANDARD-
1044                    y1 (coordinate start-y)                    y1 (coordinate start-y)
1045                    y2 (coordinate end-y)                    y2 (coordinate end-y)
1046                    initial-x1 x1                    initial-x1 x1
1047                    initial-y1 y1                    initial-y1 y1))))
                   x start-x  
                   y start-y))))  
1048      record))      record))
1049    
1050  (defmethod stream-close-text-output-record ((stream standard-output-recording-stream))  (defmethod stream-close-text-output-record
1051        ((stream standard-output-recording-stream))
1052    (let ((record (stream-current-text-output-record stream)))    (let ((record (stream-current-text-output-record stream)))
1053      (when record      (when record
1054        (setf (stream-current-text-output-record stream) nil)        (setf (stream-current-text-output-record stream) nil)
1055        #|record stream-current-cursor-position to (end-x record) - already done|#        #|record stream-current-cursor-position to (end-x record) - already done|#
1056        (stream-add-output-record stream record))))        (stream-add-output-record stream record))))
1057    
1058  (defmethod stream-add-character-output ((stream standard-output-recording-stream)  (defmethod stream-add-character-output
1059                                          character text-style      ((stream standard-output-recording-stream)
1060                                          width height baseline)       character text-style width height baseline)
1061    (add-character-output-to-text-record (stream-text-output-record stream text-style)    (add-character-output-to-text-record
1062                                         character text-style width height baseline))     (stream-text-output-record stream text-style)
1063       character text-style width height baseline))
1064    
1065  (defmethod stream-add-string-output ((stream standard-output-recording-stream)  (defmethod stream-add-string-output ((stream standard-output-recording-stream)
1066                                       string start end text-style                                       string start end text-style
1067                                       width height baseline)                                       width height baseline)
1068    (add-string-output-to-text-record (stream-text-output-record stream text-style)    (add-string-output-to-text-record (stream-text-output-record stream
1069                                                                   text-style)
1070                                      string start end text-style                                      string start end text-style
1071                                      width height baseline))                                      width height baseline))
1072    
1073    ;;; Text output catching methods
1074  (defmacro without-local-recording (stream &body body)  (defmacro without-local-recording (stream &body body)
1075    `(letf (((slot-value ,stream 'local-record-p) nil))    `(letf (((slot-value ,stream 'local-record-p) nil))
1076      ,@body))      ,@body))
1077    
1078  (defmethod stream-write-line :around ((stream standard-output-recording-stream) line)  (defmethod stream-write-line :around
1079        ((stream standard-output-recording-stream) line)
1080    (when (and (stream-recording-p stream)    (when (and (stream-recording-p stream)
1081               (slot-value stream 'local-record-p))               (slot-value stream 'local-record-p))
1082      (let* ((medium (sheet-medium stream))      (let* ((medium (sheet-medium stream))
# Line 1194  recording stream. If it is T, *STANDARD- Line 1146  recording stream. If it is T, *STANDARD-
1146    (when (stream-recording-p stream)    (when (stream-recording-p stream)
1147      (setf (text-record-wrapped (stream-text-output-record stream nil)) ; FIXME!      (setf (text-record-wrapped (stream-text-output-record stream nil)) ; FIXME!
1148            (stream-text-margin stream))))            (stream-text-margin stream))))
1149    
1150    ;;; 16.4.4. Output Recording Utilities
1151    
1152    (defmacro with-output-recording-options ((stream
1153                                              &key (record nil record-supplied-p)
1154                                                   (draw nil draw-supplied-p))
1155                                             &body body)
1156      (when (eq stream 't) (setq stream '*standard-output*))
1157      (check-type stream symbol)
1158      (with-gensyms (continuation)
1159        `(flet ((,continuation  (,stream) ,@body))
1160           (declare (dynamic-extent #',continuation))
1161           (invoke-with-output-recording-options
1162            ,stream #',continuation
1163            ,(if record-supplied-p record `(stream-recording-p ,stream))
1164            ,(if draw-supplied-p draw `(stream-drawing-p ,stream))))))
1165    
1166    (defmethod invoke-with-output-recording-options
1167      ((stream output-recording-stream) continuation record draw)
1168      "Calls CONTINUATION on STREAM enabling or disabling recording and drawing
1169    according to the flags RECORD and DRAW."
1170      (letf (((stream-recording-p stream) record)
1171             ((stream-drawing-p stream) draw))
1172        (funcall continuation stream)))
1173    
1174    (defmacro with-new-output-record ((stream
1175                                       &optional
1176                                       (record-type 'standard-sequence-output-record)
1177                                       (record nil record-supplied-p)
1178                                       &rest initargs)
1179                                      &body body)
1180      "Creates a new output record of type RECORD-TYPE and then captures
1181    the output of BODY into the new output record, and inserts the new
1182    record into the current \"open\" output record assotiated with STREAM.
1183        If RECORD is supplied, it is the name of a variable that will be
1184    lexically bound to the new output record inside the body. INITARGS are
1185    CLOS initargs that are passed to MAKE-INSTANCE when the new output
1186    record is created.
1187        It returns the created output record.
1188        The STREAM argument is a symbol that is bound to an output
1189    recording stream. If it is T, *STANDARD-OUTPUT* is used."
1190      (when (eq stream 't) (setq stream '*standard-output*))
1191      (check-type stream symbol)
1192      (unless record-supplied-p (setq record (gensym)))
1193      `(invoke-with-new-output-record ,stream
1194                                      #'(lambda (,stream ,record)
1195                                          (declare (ignorable ,stream ,record))
1196                                          ,@body)
1197                                      ',record-type
1198                                      ,@initargs))
1199    
1200    (defmethod invoke-with-new-output-record ((stream output-recording-stream)
1201                                              continuation record-type
1202                                              &rest initargs
1203                                              &key parent
1204                                              &allow-other-keys)
1205      (stream-close-text-output-record stream)
1206      (unless parent (setq parent (stream-current-output-record stream)))
1207      (let ((new-record (apply #'make-instance record-type :parent parent initargs)))
1208        (letf (((stream-current-output-record stream) new-record))
1209          ;; Should we switch on recording? -- APD
1210          (funcall continuation stream new-record)
1211          (finish-output stream))
1212        (stream-add-output-record stream new-record)
1213        new-record))
1214    
1215    (defmacro with-output-to-output-record
1216        ((stream
1217          &optional (record-type 'standard-sequence-output-record)
1218                    (record nil record-supplied-p)
1219          &rest initargs)
1220         &body body)
1221      "Creates a new output record of type RECORD-TYPE and then captures
1222    the output of BODY into the new output record. The cursor position of
1223    STREAM is initially bound to (0,0)
1224        If RECORD is supplied, it is the name of a variable that will be
1225    lexically bound to the new output record inside the body. INITARGS are
1226    CLOS initargs that are passed to MAKE-INSTANCE when the new output
1227    record is created.
1228        It returns the created output record.
1229        The STREAM argument is a symbol that is bound to an output
1230    recording stream. If it is T, *STANDARD-OUTPUT* is used."
1231      (when (eq stream 't) (setq stream '*standard-output*))
1232      (check-type stream symbol)
1233      (unless record-supplied-p (setq record (gensym "RECORD")))
1234      `(invoke-with-output-to-output-record
1235        ,stream
1236        #'(lambda (,stream ,record)
1237            (declare (ignorable ,stream ,record))
1238            ,@body)
1239        ',record-type
1240        ,@initargs))
1241    
1242    (defmethod invoke-with-output-to-output-record
1243        ((stream output-recording-stream) continuation record-type
1244         &rest initargs
1245         &key parent
1246         &allow-other-keys)
1247      (stream-close-text-output-record stream)
1248      (unless parent (setq parent (stream-current-output-record stream)))
1249      (let ((new-record (apply #'make-instance record-type
1250                               :parent parent initargs)))
1251        (with-output-recording-options (stream :record t :draw nil)
1252          (multiple-value-bind (cx cy)
1253              (stream-cursor-position stream)
1254            (unwind-protect
1255                 (letf (((stream-current-output-record stream) new-record))
1256                   (setf (stream-cursor-position stream) (values 0 0))
1257                   (funcall continuation stream new-record)
1258                   (finish-output stream))
1259              (setf (stream-cursor-position stream) (values cx cy)))))
1260        new-record))
1261    
1262    (defmethod make-design-from-output-record (record)
1263      ;; FIXME
1264      (declare (ignore record))
1265      (error "Not implemented."))
1266    
1267    
1268    ;;; Additional methods
1269    (defmethod scroll-vertical :around ((stream output-recording-stream) dy)
1270      (declare (ignore dy))
1271      (with-output-recording-options (stream :record nil)
1272        (call-next-method)))
1273    
1274    (defmethod scroll-horizontal :around ((stream output-recording-stream) dx)
1275      (declare (ignore dx))
1276      (with-output-recording-options (stream :record nil)
1277        (call-next-method)))
1278    
1279    (defmethod handle-repaint ((stream output-recording-stream) region)
1280      (stream-replay stream region))
1281    
1282    #|
1283    (defmethod handle-event :after ((stream output-recording-stream) (event pointer-button-press-event))
1284      (highlight-output-record (stream-current-output-record stream) stream :highlight))
1285    
1286    (defmethod handle-event :before ((stream output-recording-stream) (event pointer-button-release-event))
1287      (highlight-output-record (stream-current-output-record stream) stream :unhighlight))
1288    |#

Legend:
Removed from v.1.45  
changed lines
  Added in v.1.46

  ViewVC Help
Powered by ViewVC 1.1.5