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

Diff of /mcclim/recording.lisp

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

revision 1.63 by mikemac, Fri Mar 21 22:07:06 2003 UTC revision 1.64 by moore, Wed Apr 2 07:48:59 2003 UTC
# Line 65  Line 65 
65  ;;; output record class"? Is it OUTPUT-RECORD or BASIC-OUTPUT-RECORD?  ;;; output record class"? Is it OUTPUT-RECORD or BASIC-OUTPUT-RECORD?
66  ;;; Now they are defined on OUTPUT-RECORD.  ;;; Now they are defined on OUTPUT-RECORD.
67    
 ;;; TDO  
 ;;;  
 ;;; Text output record must save ink and clipping region. But its  
 ;;; protocol does not give any way to do it! And a user can put in a  
 ;;; history a record of any class :(. Now we are using  
 ;;; *DRAWING-OPTIONS* to put the necessary information and make sure  
 ;;; that only instances of STANDARD-TEXT-OUTPUT-RECORD are used for  
 ;;; recording. -- APD, 2002-06-15.  
68    
69  (in-package :clim-internals)  (in-package :clim-internals)
70    
# Line 275  unspecified. ")) Line 267  unspecified. "))
267  ;;; 21.3 Incremental Redisplay Protocol.  These generic functions need  ;;; 21.3 Incremental Redisplay Protocol.  These generic functions need
268  ;;; to be implemented for all the basic displayed-output-records, so they are  ;;; to be implemented for all the basic displayed-output-records, so they are
269  ;;; defined in this file.  ;;; defined in this file.
270    ;;;
271    ;;; match-output-records and find-child-output-record, as defined in
272    ;;; the CLIM spec, are pretty silly.  How does incremental redisplay know
273    ;;; what keyword arguments to supply to find-child-output-record?  Through
274    ;;; a gf specialized on the type of the record it needs to match... why
275    ;;; not define the search function and the predicate on two records then!
276    ;;;
277    ;;; We'll implement match-output-records and find-child-output-record,
278    ;;; but we won't actually use them.  Instead, output-record-equal will
279    ;;; match two records, and find-child-record-equal will search for the
280    ;;; equivalent record.
281    
282  (defgeneric match-output-records (record &rest args))  (defgeneric match-output-records (record &rest args))
283    
284    ;;; These gf's use :most-specific-last because one of the least
285    ;;; specific methods will check the bounding boxes of the records, which
286    ;;; should cause an early out most of the time.
287    
288  (defgeneric match-output-records-1 (record &key)  (defgeneric match-output-records-1 (record &key)
289    (:method-combination and :most-specific-last))    (:method-combination and :most-specific-last))
290    
291    (defgeneric output-record-equal (record1 record2)
292      (:method-combination and :most-specific-last))
293    
294    (defmethod output-record-equal :around (record1 record2)
295      (if (eq (class-of record1) (class-of record2))
296          (call-next-method)
297          nil))
298    
299    ;;; The code for match-output-records-1 and output-record-equal
300    ;;; methods are very similar, hence this macro.  In order to exploit
301    ;;; the similarities, it's necessary to treat the slots of the second
302    ;;; record like variables, so for convenience the macro will use
303    ;;; slot-value on both records.
304    
305    (defmacro defrecord-predicate (record-type slots &body body)
306      "Each element of SLOTS is either a symbol or (:initarg-name slot-name)."
307      (let* ((slot-names (mapcar #'(lambda (slot-spec)
308                                     (if (consp slot-spec)
309                                         (cadr slot-spec)
310                                         slot-spec))
311                                 slots))
312             (supplied-vars (mapcar #'(lambda (slot)
313                                        (gensym (symbol-name
314                                                 (symbol-concat slot '#:-p))))
315                                    slot-names))
316             (key-args (mapcar #'(lambda (slot-spec supplied)
317                                   `(,slot-spec nil ,supplied))
318                               slots supplied-vars))
319             (key-arg-alist (mapcar #'cons slot-names supplied-vars)))
320        `(progn
321           (defmethod output-record-equal and ((record ,record-type)
322                                               (record2 ,record-type))
323             (macrolet ((if-supplied (var &body supplied-body)
324                          (declare (ignore var))
325                          `(progn ,@supplied-body)))
326               (with-slots ,slot-names
327                   record2
328                 ,@body)))
329           (defmethod match-output-records-1 and ((record ,record-type)
330                                                  &key ,@key-args)
331             (macrolet ((if-supplied (var &body supplied-body)
332                          (let ((supplied-var (cdr (assoc var ',key-arg-alist))))
333                            (unless supplied-var
334                              (error "Unknown slot ~S" var))
335                            `(or (null ,supplied-var)
336                                 (progn ,@supplied-body)))))
337               ,@body)))
338    
339        ))
340  ;;; Macros  ;;; Macros
341  (defmacro with-output-recording-options ((stream  (defmacro with-output-recording-options ((stream
342                                            &key (record nil record-supplied-p)                                            &key (record nil record-supplied-p)
# Line 829  were added." Line 885  were added."
885  (defmethod set-medium-graphics-state :after ((state gs-ink-mixin) medium)  (defmethod set-medium-graphics-state :after ((state gs-ink-mixin) medium)
886    (setf (medium-ink medium) (graphics-state-ink state)))    (setf (medium-ink medium) (graphics-state-ink state)))
887    
888  (defmethod match-output-records-1 and ((record gs-ink-mixin)  (defrecord-predicate gs-ink-mixin (ink)
889                                         &key (ink nil inkp))    (if-supplied ink
890    (or (null inkp)      (design-equalp (slot-value record 'ink) ink)))
       (design-equalp (graphics-state-ink record) ink)))  
891    
892  (defclass gs-clip-mixin (graphics-state)  (defclass gs-clip-mixin (graphics-state)
893    ((clip :initarg :clipping-region :accessor graphics-state-clip    ((clip :initarg :clipping-region :accessor graphics-state-clip
# Line 884  were added." Line 939  were added."
939    (or clipp    (or clipp
940        (region-equal (graphics-state-clip record) clip)))        (region-equal (graphics-state-clip record) clip)))
941    
942    (defrecord-predicate gs-clip-mixin ((:clipping-region clip))
943      (if-supplied clip
944        (region-equal (slot-value record 'clip) clip)))
945    
946  ;;; 16.3.2. Graphics Displayed Output Records  ;;; 16.3.2. Graphics Displayed Output Records
947  (defclass standard-displayed-output-record (gs-clip-mixin gs-ink-mixin  (defclass standard-displayed-output-record (gs-clip-mixin gs-ink-mixin
948                                              basic-output-record                                              basic-output-record
# Line 905  were added." Line 964  were added."
964  (defmethod set-medium-graphics-state :after ((state gs-line-style-mixin) medium)  (defmethod set-medium-graphics-state :after ((state gs-line-style-mixin) medium)
965    (setf (medium-line-style medium) (graphics-state-line-style state)))    (setf (medium-line-style medium) (graphics-state-line-style state)))
966    
967  (defmethod match-output-records-1 and ((record gs-line-style-mixin)  (defrecord-predicate gs-line-style-mixin (line-style)
968                                         &key (line-style nil line-style-p))    (if-supplied line-style
969    (or (null line-style-p)      (line-style-equalp (slot-value record 'line-style) line-style)))
       (line-style-equalp (graphics-state-line-style record) line-style)))  
970    
971  (defgeneric graphics-state-line-style-border (record medium)  (defgeneric graphics-state-line-style-border (record medium)
972    (:method ((record gs-line-style-mixin) medium)    (:method ((record gs-line-style-mixin) medium)
# Line 930  were added." Line 988  were added."
988  (defmethod set-medium-graphics-state :after ((state gs-text-style-mixin) medium)  (defmethod set-medium-graphics-state :after ((state gs-text-style-mixin) medium)
989    (setf (medium-text-style medium) (graphics-state-text-style state)))    (setf (medium-text-style medium) (graphics-state-text-style state)))
990    
991  (defmethod match-output-records-1 and ((record gs-text-style-mixin)  (defrecord-predicate gs-text-style-mixin (text-style)
992                                         &key (text-style nil text-style-p))    (if-supplied text-style
993    (or (null text-style-p)      (text-style-equalp (slot-value record 'text-style) text-style)))
       (text-style-equalp (graphics-state-text-style record) text-style)))  
994    
995  (defclass standard-graphics-displayed-output-record  (defclass standard-graphics-displayed-output-record
996      (standard-displayed-output-record      (standard-displayed-output-record
# Line 954  were added." Line 1011  were added."
1011               (or (null x2-p) (coordinate= my-x2 x2))               (or (null x2-p) (coordinate= my-x2 x2))
1012               (or (null y2-p) (coordinate= my-y2 y2))))))               (or (null y2-p) (coordinate= my-y2 y2))))))
1013    
1014    (defmethod output-record-equal and ((record standard-displayed-output-record)
1015                                        (record2 standard-displayed-output-record))
1016      (region-equal record record2))
1017    
1018  ;;; This is an around method so that more specific before methods can be  ;;; This is an around method so that more specific before methods can be
1019  ;;; defined for the various mixin classes, that modify the state after it has  ;;; defined for the various mixin classes, that modify the state after it has
1020  ;;; been set in the graphics state.  ;;; been set in the graphics state.
# Line 1018  were added." Line 1079  were added."
1079                     for elt2 across coord-seq                     for elt2 across coord-seq
1080                     always (coordinate= elt1 elt2))))))                     always (coordinate= elt1 elt2))))))
1081    
 ;;; Do we need to save/restore graphics state in each call to  
 ;;; replay-output-record, or could we do it only in replay?  I'd like to save  
 ;;; state in a graphics state object, but I'm not going to allocate one in each  
 ;;; recursive invocation of replay-output-record :P -- moore  
   
1082  (defmacro def-grecording (name ((&rest mixins) &rest args) &body body)  (defmacro def-grecording (name ((&rest mixins) &rest args) &body body)
1083    (let ((method-name (symbol-concat '#:medium- name '*))    (let ((method-name (symbol-concat '#:medium- name '*))
1084          (class-name (symbol-concat name '#:-output-record))          (class-name (symbol-concat name '#:-output-record))
# Line 1087  were added." Line 1143  were added."
1143          (incf point-x dx)          (incf point-x dx)
1144          (incf point-y dy)))))          (incf point-y dy)))))
1145    
1146  (defmethod match-output-records-1 and ((record draw-point-output-record)  (defrecord-predicate draw-point-output-record (point-x point-y)
1147                                         &key (point-x nil point-x-p)    (and (if-supplied point-x
1148                                         (point-y nil point-y-p))           (coordinate= (slot-value record 'point-x) point-x))
1149    (and (or (null point-x-p)         (if-supplied point-y
1150             (coordinate= (slot-value record 'point-x) point-x))           (coordinate= (slot-value record 'point-y) point-y))))
        (or (null point-y-p)  
            (coordinate= (slot-value record 'point-y) point-y))))  
   
1151    
1152  (def-grecording draw-points ((coord-seq-mixin gs-line-style-mixin) coord-seq)  (def-grecording draw-points ((coord-seq-mixin gs-line-style-mixin) coord-seq)
1153    ;; coord-seq has already been transformed    ;; coord-seq has already been transformed
# Line 1130  were added." Line 1183  were added."
1183          (incf point-x2 dx)          (incf point-x2 dx)
1184          (incf point-y2 dy)))))          (incf point-y2 dy)))))
1185    
1186  (defmethod match-output-records-1 and ((record draw-line-output-record)  (defrecord-predicate draw-line-output-record (point-x1 point-y1
1187                                         &key (point-x1 nil point-x1-p)                                                point-x2 point-y2)
1188                                         (point-y1 nil point-y1-p)    (and (if-supplied point-x1
1189                                         (point-x2 nil point-x2-p)           (coordinate= (slot-value record 'point-x1) point-x1))
1190                                         (point-y2 nil point-y2-p))         (if-supplied point-y1
1191    (and (or (null point-x1-p)           (coordinate= (slot-value record 'point-y1) point-y1))
1192             (coordinate= (slot-value record 'point-x1) point-x1))         (if-supplied point-x2
1193         (or (null point-y1-p)           (coordinate= (slot-value record 'point-x2) point-x2))
1194             (coordinate= (slot-value record 'point-y1) point-y1))         (if-supplied point-y2
1195         (or (null point-x2-p)           (coordinate= (slot-value record 'point-y2) point-y2))))
            (coordinate= (slot-value record 'point-x2) point-x2))  
        (or (null point-y2-p)  
            (coordinate= (slot-value record 'point-y2) point-y2))))  
   
1196    
1197  (def-grecording draw-lines ((coord-seq-mixin gs-line-style-mixin) coord-seq)  (def-grecording draw-lines ((coord-seq-mixin gs-line-style-mixin) coord-seq)
1198    (let ((border (graphics-state-line-style-border graphic medium)))    (let ((border (graphics-state-line-style-border graphic medium)))
1199      (coord-seq-bounds coord-seq border)))      (coord-seq-bounds coord-seq border)))
1200    
1201    ;;; (setf output-record-position) and predicates for draw-lines-output-record
1202    ;;; are taken care of by methods on superclasses.
1203    
1204  ;;; Helper function  ;;; Helper function
1205  (defun normalize-coords (dx dy &optional unit)  (defun normalize-coords (dx dy &optional unit)
1206    (let ((norm (sqrt (+ (* dx dx) (* dy dy)))))    (let ((norm (sqrt (+ (* dx dx) (* dy dy)))))
# Line 1266  were added." Line 1318  were added."
1318      (polygon-record-bounding-rectangle      (polygon-record-bounding-rectangle
1319       coord-seq closed filled line-style border (medium-miter-limit medium))))       coord-seq closed filled line-style border (medium-miter-limit medium))))
1320    
1321  (defmethod match-output-records-1 and ((record draw-polygon-output-record)  (defrecord-predicate draw-polygon-output-record (closed filled)
1322                                         &key (closed nil closedp)    (and (if-supplied closed
1323                                         (filled nil filledp))           (eql (slot-value record 'closed) closed))
1324    (and (or (null closedp)         (if-supplied filled
1325             (eql (slot-value record 'closed) closed))           (eql (slot-value record 'filled) filled))))
        (or (null filledp)  
            (eql (slot-value record 'filled) filled))))  
1326    
1327  (def-grecording draw-rectangle ((gs-line-style-mixin)  (def-grecording draw-rectangle ((gs-line-style-mixin)
1328                                  left top right bottom filled)                                  left top right bottom filled)
# Line 1296  were added." Line 1346  were added."
1346          (incf right dx)          (incf right dx)
1347          (incf bottom dy)))))          (incf bottom dy)))))
1348    
1349  (defmethod match-output-records-1 and ((record draw-rectangle-output-record)  (defrecord-predicate draw-rectangle-output-record (left top right bottom filled)
1350                                         &key (left nil leftp)    (and (if-supplied left
1351                                         (top nil topp)           (coordinate= (slot-value record 'left) left))
1352                                         (right nil rightp)         (if-supplied top
1353                                         (bottom nil bottomp)           (coordinate= (slot-value record 'top) top))
1354                                         (filled nil filledp))         (if-supplied right
1355    (and (or (null leftp)           (coordinate= (slot-value record 'right) right))
1356             (coordinate= (slot-value record 'left) left))         (if-supplied bottom
1357         (or (null topp)           (coordinate= (slot-value record 'bottom) bottom))
1358             (coordinate= (slot-value record 'top) top))         (if-supplied filled
1359         (or (null rightp)           (eql (slot-value record 'filled) filled))))
            (coordinate= (slot-value record 'right) right))  
        (or (null bottomp)  
            (coordinate= (slot-value record 'bottom) bottom))  
        (or (null filledp)  
            (eql (slot-value record 'filled) filled))))  
1360    
1361  (def-grecording draw-ellipse ((gs-line-style-mixin)  (def-grecording draw-ellipse ((gs-line-style-mixin)
1362                                center-x center-y                                center-x center-y
# Line 1342  were added." Line 1387  were added."
1387          (incf center-x dx)          (incf center-x dx)
1388          (incf center-y dy)))))          (incf center-y dy)))))
1389    
1390  (defmethod match-output-records-1 and ((record draw-ellipse-output-record)  (defrecord-predicate draw-ellipse-output-record (center-x center-y)
1391                                         &key (center-x nil center-x-p)    (and (if-supplied center-x
                                        (center-y nil center-y-p))  
   (and (or (null center-x-p)  
1392             (coordinate= (slot-value record 'center-x) center-x))             (coordinate= (slot-value record 'center-x) center-x))
1393         (or (null center-y-p)         (if-supplied center-y
1394             (coordinate= (slot-value record 'center-y) center-y))))             (coordinate= (slot-value record 'center-y) center-y))))
1395    
1396  (def-grecording draw-text ((gs-text-style-mixin) string point-x point-y start end  (def-grecording draw-text ((gs-text-style-mixin) string point-x point-y start end
# Line 1393  were added." Line 1436  were added."
1436          (incf toward-x dx)          (incf toward-x dx)
1437          (incf toward-y dy)))))          (incf toward-y dy)))))
1438    
1439  (defmethod match-output-records-1 and ((record draw-text-output-record)  (defrecord-predicate draw-text-output-record
1440                                         &key (string nil stringp)      (string start end point-x point-y align-x align-y toward-x toward-y
1441                                         (start nil startp)       transform-glyphs)
1442                                         (end nil endp)    (and (if-supplied string
1443                                         (point-x nil point-x-p)           (string= (slot-value record 'string) string))
1444                                         (point-y nil point-y-p)         (if-supplied start
1445                                         (align-x nil align-x-p)           (eql (slot-value record 'start) start))
1446                                         (align-y nil align-y-p)         (if-supplied end
1447                                         (toward-x nil toward-x-p)           (eql (slot-value record 'end) end))
1448                                         (toward-y nil toward-y-p)         (if-supplied point-x
1449                                         (transform-glyphs nil           (coordinate= (slot-value record 'point-x) point-x))
1450                                                           transform-glyphs-p))         (if-supplied point-y
1451     (and (or (null stringp)           (coordinate= (slot-value record 'point-y) point-y))
1452              (string= (slot-value record 'string) string))         (if-supplied align-x
1453          (or (null startp)           (eq (slot-value record 'align-x) align-x))
1454              (eql (slot-value record 'start) start))         (if-supplied align-y
1455          (or (null endp)           (eq (slot-value record 'align-y) align-y))
1456              (eql (slot-value record 'end) end))         (if-supplied toward-x
1457          (or (null point-x-p)           (coordinate= (slot-value record 'toward-x) toward-x))
1458              (coordinate= (slot-value record 'point-x) point-x))         (if-supplied toward-y
1459          (or (null point-y-p)           (coordinate= (slot-value record 'toward-y) toward-y))
1460              (coordinate= (slot-value record 'point-y) point-y))         (if-supplied transform-glyphs
1461          (or (null align-x-p)           (eq (slot-value record 'transform-glyphs) transform-glyphs))))
             (eq (slot-value record 'align-x) align-x))  
         (or (null align-y-p)  
             (eq (slot-value record 'align-y) align-y))  
         (or (null toward-x-p)  
             (coordinate= (slot-value record 'toward-x) toward-x))  
         (or (null toward-y-p)  
             (coordinate= (slot-value record 'toward-y) toward-y))  
         (or (null transform-glyphs-p)  
             (eq (slot-value record 'transform-glyphs) transform-glyphs))))  
1462    
1463  ;;; 16.3.3. Text Displayed Output Record  ;;; 16.3.3. Text Displayed Output Record
 (defvar *drawing-options* (list +foreground-ink+ +everywhere+)  
   "The ink and the clipping region of the current stream.") ; XXX TDO  
1464    
1465  (defclass styled-string (gs-text-style-mixin gs-clip-mixin gs-ink-mixin)  (defclass styled-string (gs-text-style-mixin gs-clip-mixin gs-ink-mixin)
1466    ((start-x :initarg :start-x)    ((start-x :initarg :start-x)
1467     (string :initarg :string :reader styled-string-string)))     (string :initarg :string :reader styled-string-string)))
1468    
1469    (defmethod output-record-equal and ((record styled-string)
1470                                        (record2 styled-string))
1471      (and (coordinate= (slot-value record 'start-x)
1472                        (slot-value record2 'start-x))
1473           (string= (slot-value record 'string)
1474                    (slot-value record2 'string))))
1475    
1476  (defclass standard-text-displayed-output-record  (defclass standard-text-displayed-output-record
1477      (text-displayed-output-record standard-displayed-output-record)      (text-displayed-output-record standard-displayed-output-record)
1478    ((initial-x1 :initarg :start-x)    ((initial-x1 :initarg :start-x)
# Line 1455  were added." Line 1494  were added."
1494    (when stream    (when stream
1495      (setf (slot-value obj 'medium) (sheet-medium stream))))      (setf (slot-value obj 'medium) (sheet-medium stream))))
1496    
1497    ;;; Forget match-output-records-1 for standard-text-displayed-output-record; it
1498    ;;; doesn't make much sense because these records have state that is not
1499    ;;; initialized via initargs.
1500    
1501    (defmethod output-record-equal and
1502        ((record standard-text-displayed-output-record)
1503         (record2 standard-text-displayed-output-record))
1504      (with-slots
1505            (initial-x1 initial-y1 start-x start-y end-x end-y wrapped strings)
1506          record2
1507        (and (coordinate= (slot-value record 'initial-x1) initial-x1)
1508             (coordinate= (slot-value record 'initial-y1) initial-y1)
1509             (coordinate= (slot-value record 'start-x) start-x)
1510             (coordinate= (slot-value record 'start-y) start-y)
1511             (coordinate= (slot-value record 'end-x) end-x)
1512             (coordinate= (slot-value record 'end-y) end-y)
1513             (eq (slot-value record 'wrapped) wrapped)
1514             (coordinate= (slot-value record 'baseline)
1515                          (slot-value record2 'baseline))
1516             (eql (length (slot-value record 'strings)) (length strings));XXX
1517             (loop for s1 in (slot-value record 'strings)
1518                   for s2 in strings
1519                   always (output-record-equal s1 s2))))))
1520    
1521  (defmethod print-object ((self standard-text-displayed-output-record) stream)  (defmethod print-object ((self standard-text-displayed-output-record) stream)
1522    (print-unreadable-object (self stream :type t :identity t)    (print-unreadable-object (self stream :type t :identity t)
1523      (with-slots (start-x start-y strings) self      (with-slots (start-x start-y strings) self
# Line 1714  were added." Line 1777  were added."
1777    (when (and (stream-recording-p stream)    (when (and (stream-recording-p stream)
1778               (slot-value stream 'local-record-p))               (slot-value stream 'local-record-p))
1779      (let* ((medium (sheet-medium stream))      (let* ((medium (sheet-medium stream))
1780             (text-style (medium-text-style medium))             (text-style (medium-text-style medium)))
            (*drawing-options* (list (medium-ink medium) ; XXX TDO  
                                     (medium-clipping-region medium))))  
1781        (stream-add-string-output stream line 0 nil text-style        (stream-add-string-output stream line 0 nil text-style
1782                                  (stream-string-width stream line                                  (stream-string-width stream line
1783                                                       :text-style text-style)                                                       :text-style text-style)
# Line 1841  according to the flags RECORD and DRAW." Line 1902  according to the flags RECORD and DRAW."
1902  (defmethod handle-repaint ((stream output-recording-stream) region)  (defmethod handle-repaint ((stream output-recording-stream) region)
1903    (stream-replay stream region))    (stream-replay stream region))
1904    
1905    (defmethod scroll-extent :around ((stream output-recording-stream) x y)
1906      (when (stream-drawing-p stream)
1907        (call-next-method)))

Legend:
Removed from v.1.63  
changed lines
  Added in v.1.64

  ViewVC Help
Powered by ViewVC 1.1.5