racket/draw: add `record-dc%'

collects/racket/draw.rkt

@@ -11,6 +11,7 @@
          "draw/private/dc-path.rkt"
          "draw/private/dc-intf.rkt"
          "draw/private/bitmap-dc.rkt"
+         "draw/private/record-dc.rkt"
          "draw/private/post-script-dc.rkt"
          "draw/private/ps-setup.rkt"
          "draw/private/svg-dc.rkt"
@@ -30,6 +31,7 @@
          dc-path%
          dc<%>
          bitmap-dc%
+         record-dc% recorded-datum->procedure
          post-script-dc%
          pdf-dc%
          ps-setup% current-ps-setup

collects/racket/draw/private/dc-path.rkt

@@ -14,11 +14,16 @@
 
 (provide dc-path%
          (protect-out do-path
-                      set-text-to-path!))
+                      set-text-to-path!
+                      
+                      get-closed-points
+                      get-open-points
+                      set-closed+open-points))
 
 (define-local-member-name
   get-closed-points
   get-open-points
+  set-closed+open-points
   do-path)
 
 (define 2pi (* 2.0 pi))
@@ -52,8 +57,33 @@
     (define/public (get-closed-points) (flatten-closed!) closed-points)
     (define/public (get-open-points) (flatten-open!) open-points)
 
+    (define/public (set-closed+open-points c o)
+      (define (ok-points? l)
+        (let loop ([l l])
+          (cond
+           [(null? l) #t]
+           [(pair? l)
+            (let ([p (car l)])
+              (if (pair? p)
+                  (and (real? (car p))
+                       (real? (cdr p))
+                       (loop (cdr l)))
+                  (and (vector? p)
+                       (= (vector-length p) 4)
+                       (real? (vector-ref p 0))
+                       (real? (vector-ref p 1))
+                       (real? (vector-ref p 2))
+                       (real? (vector-ref p 3))
+                       (pair? (cdr l))
+                       (pair? (cadr l))
+                       (loop (cdr l)))))])))
+      (unless (and (andmap ok-points? c) (ok-points? o))
+        (error "invalid path points"))
+      (set! closed-points c)
+      (set! open-points o))
+
     (define/private (do-points cr l align-x align-y)
-      (let loop ([l l][first? #t])
+      (let loop ([l l] [first? #t])
         (cond
          [(null? l) (void)]
          [else

collects/racket/draw/private/dc.rkt

@@ -575,17 +575,17 @@
       (let ([o pen])
         (send p adjust-lock 1)
         (set! pen p)
-        (send o adjust-lock -1)))
+        (send o adjust-lock -1))
+      (reset-align!))
 
     (define/public (set-pen . args)
       (case-args
        args
-       [([pen% p]) (do-set-pen! p) (reset-align!)]
+       [([pen% p]) (do-set-pen! p)]
        [([(make-alts string? color%) col]
          [pen-width? width]
          [pen-style-symbol? style])
-        (do-set-pen! (send the-pen-list find-or-create-pen col width style))
+        (do-set-pen! (send the-pen-list find-or-create-pen col width style))]
-        (reset-align!)]
        (method-name 'dc<%> 'set-pen)))
 
     (define/public (get-pen) pen)

collects/racket/draw/private/record-dc.rkt

@@ -1,38 +1,61 @@
 #lang racket/base
 (require racket/class
          ffi/unsafe/atomic
+         "../unsafe/cairo.rkt"
+         "local.rkt"
+         "syntax.rkt"
          "dc.rkt"
+         "dc-intf.rkt"
          "bitmap.rkt"
          "bitmap-dc.rkt"
          "color.rkt"
          "point.rkt"
          "pen.rkt"
          "brush.rkt"
+         "font.rkt"
          "region.rkt"
-         "dc-path.rkt")
+         "dc-path.rkt"
+         "gradient.rkt"
+         (for-syntax racket/base))
 
-(provide record-dc-mixin
+(provide record-dc%
+         recorded-datum->procedure
+         (protect-out record-dc-mixin
                       get-recorded-command
                       reset-recording
-         set-recording-limit)
+                      set-recording-limit))
 
 (define-local-member-name
   get-recorded-command
   reset-recording
-  set-recording-limit)
+  set-recording-limit
+  record-unconvert)
 
 (define black (send the-color-database find-color "black"))
 
 (define (clone-point p)
   (if (pair? p)
       p
-      (make-object point% (point-x p) (point-y p))))
+      (cons (point-x p) (point-y p))))
+
+(define (clone-points ps)
+  (map clone-point ps))
 
 (define (clone-color c)
   (if (string? c)
       (string->immutable-string c)
       (color->immutable-color c)))
 
+(define (convert-color c)
+  (if (string? c)
+      (string->immutable-string c)
+      (list (color-red c) (color-green c) (color-blue c) (color-alpha c))))
+
+(define (unconvert-color c)
+  (if (string? c)
+      (string->immutable-string c)
+      (make-object color% (car c) (cadr c) (caddr c) (cadddr c))))
+
 (define (clone-pen p)
   (let ([s (send p get-stipple)])
     (if s
@@ -51,6 +74,25 @@
               (send p get-cap)
               (send p get-join)))))
 
+(define (convert-pen p)
+  (let ([s (send p get-stipple)])
+    (list (convert-color (send p get-color))
+          (send p get-width)
+          (send p get-style)
+          (send p get-cap)
+          (send p get-join)
+          (and s (convert-bitmap s)))))
+
+(define (unconvert-pen l)
+  (define-values (c width style cap join stipple)
+    (apply values l))
+  (define color (unconvert-color c))
+  (if stipple
+      (let ([p (make-object pen% color width style cap join)])
+        (send p set-stipple (unconvert-bitmap stipple))
+        p)
+        (send the-pen-list find-or-create-pen color width style cap join)))
+
 (define (clone-brush b)
   (let ([s (send b get-stipple)])
     (if s
@@ -72,6 +114,55 @@
                     (send b get-color)
                     (send b get-style)))))))
 
+(define (convert-brush b)
+  (let ([s (send b get-stipple)]
+        [g (send b get-gradient)])
+    (list (convert-color (send b get-color))
+          (send b get-style)
+          (and s (convert-bitmap s))
+          (and g (convert-gradient g))
+          (send b get-transformation))))
+
+(define (unconvert-brush l)
+  (define-values (c style stipple gradient transformation)
+    (apply values l))
+  (define color (unconvert-color c))
+  (if stipple
+      (let ([b (make-object brush% color style)])
+        (send b set-stipple (unconvert-bitmap stipple) 
+              transformation)
+        b)
+      (if gradient
+          (make-object brush% 
+                       color
+                       style
+                       #f
+                       (unconvert-gradient gradient)
+                       transformation)
+          (send the-brush-list find-or-create-brush color style))))
+
+(define (convert-gradient g)
+  (if (g . is-a? . linear-gradient%)
+      (let-values ([(x1 y1 x2 y2) (send g get-line)])
+        (list x1 y1 x2 y2 (convert-stops (send g get-stops))))
+      (let-values ([(x1 y1 r1 x2 y2 r2) (send g get-circles)])
+        (list x1 y1 r1 x2 y2 r2 (convert-stops (send g get-stops))))))
+
+(define (unconvert-gradient l)
+  (if (= (length l) 5)
+      (make-object linear-gradient% 
+                   (car l) (cadr l) (caddr l) (cadddr l)
+                   (unconvert-stops (list-ref l 4)))
+      (make-object radial-gradient% 
+                   (car l) (cadr l) (caddr l) 
+                   (list-ref l 3) (list-ref l 4) (list-ref l 5)
+                   (unconvert-stops (list-ref l 6)))))
+
+(define (convert-stops s)
+  (for/list ([i (in-list s)]) (cons (car i) (convert-color (cadr i)))))
+(define (unconvert-stops s)
+  (for/list ([i (in-list s)]) (list (car i) (unconvert-color (cdr i)))))
+
 (define (region-maker r)
   (if (send r internal-get-dc)
       (let ([paths (send r get-paths)])
@@ -83,12 +174,41 @@
         (send new-r union r)
         (lambda (dc) new-r))))
 
+(define (convert-region r)
+  (and r
+       (cons (and (send r internal-get-dc) #t)
+             (map convert-path (send r get-paths)))))
+
+(define (unconvert-region l)
+  (if l
+      (let ()
+        (define paths (map unconvert-path (cdr l)))
+        (if (car l)
+            (lambda (dc)
+              (let ([new-r (make-object region% (and (car l) dc))])
+                (send new-r set-paths! paths)
+                new-r))
+            (let ([new-r (make-object region%)])
+              (send new-r set-paths! paths)
+              (lambda (dc) new-r))))
+      (lambda (dc) #f)))
+
 (define (clone-path p)
   (let ([new-p (make-object dc-path%)])
     (send new-p append p)
     p))
 
+(define (convert-path p)
+  (cons (send p get-closed-points)
+        (send p get-open-points)))
+
+(define (unconvert-path l)
+  (define p (new dc-path%))
+  (send p set-closed+open-points (car l) (cdr l))
+  p)
+
 (define (clone-bitmap b)
+  (and b
        (let* ([new-b (make-object bitmap% 
                                   (send b get-width) 
                                   (send b get-height)
@@ -97,7 +217,41 @@
               [dc (make-object bitmap-dc% new-b)])
          (send dc draw-bitmap b 0 0)
          (send dc set-bitmap #f)
-    new-b))
+         new-b)))
+
+(define (convert-bitmap b)
+  (and b
+       (let ()
+         (define w (send b get-width))
+         (define h (send b get-height))
+         (define bstr (make-bytes (* 4 w h)))
+         (send b get-argb-pixels 0 0 w h bstr)
+         (list w h 
+               (send b is-color?)
+               (send b has-alpha-channel?)
+               (bytes->immutable-bytes bstr)))))
+
+(define (unconvert-bitmap l)
+  (and l
+       (let ()
+         (define-values (w h color? alpha? bstr)
+           (apply values l))
+         (define bm (make-object bitmap% w h (not color?) alpha?))
+         (send bm set-argb-pixels 0 0 w h bstr)
+         bm)))
+
+(define (convert-font f)
+  (list (send f get-point-size)
+        (send f get-face)
+        (send f get-family)
+        (send f get-style)
+        (send f get-weight)
+        (send f get-underlined)
+        (send f get-smoothing)
+        (send f get-size-in-pixels)))
+
+(define (unconvert-font l)
+  (apply make-object font% l))
 
 (define (record-dc-mixin %)
   (class %
@@ -106,7 +260,8 @@
     (inherit get-origin get-scale get-rotation get-initial-matrix 
              get-pen get-brush get-font
              get-smoothing get-text-mode 
-             get-alpha get-clipping-region)
+             get-alpha get-clipping-region
+             translate rotate scale)
 
     (define record-limit +inf.0)
     (define current-size 0)
@@ -116,29 +271,126 @@
     (define/private (continue-recording?)
       (current-size . < . record-limit))
 
-    (define-syntax-rule (define/record (name arg ...))
+    (define-syntax (define/record stx)
-      (define/override (name arg ...)
+      (syntax-case stx ()
-        (super name arg ...)
+        [(_ (name arg ...))
-        (record (lambda (dc) (send dc name arg ...)))))
+         (let ([args (syntax->list #'(arg ...))])
+           (with-syntax ([(arg-id ...)
+                          (map (lambda (arg)
+                                 (syntax-case arg ()
+                                   [([id def-val]) #'id]
+                                   [([id def-val] clone-id convert-id unconvert-id) #'id]
+                                   [(id clone-id convert-id unconvert-id) #'id]
+                                   [(id clone-id) #'id]
+                                   [else arg]))
+                               args)]
+                         [(arg-formal ...)
+                          (map (lambda (arg)
+                                 (syntax-case arg ()
+                                   [(id) #'id]
+                                   [(id clone-id convert-id unconvert-id) #'id]
+                                   [(id clone-id) #'id]
+                                   [else arg]))
+                               args)]
+                         [(arg-bind ...)
+                          (map (lambda (arg)
+                                 (syntax-case arg ()
+                                   [([id def-val])
+                                    #'[id id]]
+                                   [([id def-val] clone-id convert-id unconvert-id)
+                                    #'[id (clone clone-id id)]]
+                                   [(id clone-id convert-id unconvert-id)
+                                    #'[id (clone clone-id id)]]
+                                   [(id clone-id)
+                                    #'[id (clone clone-id id)]]
+                                   [id
+                                    #'[id id]]))
+                               args)]
+                         [((arg-convert ...) ...)
+                          (map (lambda (arg)
+                                 (syntax-case arg ()
+                                   [(formal clone-id convert-id unconvert-id)
+                                    #'(convert convert-id)]
+                                   [_ #'(values)]))
+                               args)])
+             #'(define/override (name arg-formal ...)
+                 (super name arg-id ...)
+                 (when (continue-recording?)
+                   (let (arg-bind ...)
+                     (record (lambda (dc) (send dc name arg-id ...))
+                             (lambda () (list 'name (arg-convert ... arg-id) ...))))))))]))
+
+    (define-syntax (generate-record-unconvert stx)
+      (syntax-case stx ()
+        [(_ ([clause-tags clause-rhs] ...) (defn (name arg ...)) ...)
+         (with-syntax ([((arg-id ...) ...)
+                        (let ([names (syntax->list #'(name ...))]
+                              [argss (syntax->list #'((arg ...) ...))])
+                          (map (lambda (name args)
+                                 (map (lambda (arg)
+                                        (syntax-case arg ()
+                                          [([id def-val]) #'id]
+                                          [([id def-val] clone-id convert-id unconvert-id) #'id]
+                                          [(id clone-id convert-id unconvert-id) #'id]
+                                          [(id clone-id) #'id]
+                                          [else arg]))
+                                      (syntax->list args)))
+                               names
+                               argss))]
+                       [(((arg-bind ...) ...) ...)
+                        (let ([argss (syntax->list #'((arg ...) ...))])
+                          (map (lambda (args)
+                                 (map (lambda (arg)
+                                        (syntax-case arg ()
+                                          [([id def-val] clone-id convert-id unconvert-id)
+                                           #'([id (unconvert-id id)])]
+                                          [(id clone-id convert-id unconvert-id)
+                                           #'([id (unconvert-id id)])]
+                                          [_ #'()]))
+                                      (syntax->list args)))
+                               argss))])
+           #'(begin
+               (defn (name arg ...)) ...
+               (define/public (record-unconvert cmds)
+                 (for/list ([cmd (in-list cmds)])
+                   (define cmd-tag (car cmd))
+                   (define cmd-args (cdr cmd))
+                   (case cmd-tag
+                     [clause-tags (apply clause-rhs cmd-args)] ...
+                     [(name)
+                      (apply (lambda (arg-id ...)
+                               (let (arg-bind ... ...)
+                                 (lambda (dc) (send dc name arg-id ...))))
+                             cmd-args)]
+                     ...
+                     [else (error 'unconvert "bad datum: ~e" cmd-tag)])))))]))
 
     (define procs null)
-    (define/private (record proc)
+    (define converts null)
+    (define/private (record proc convert)
       (when (continue-recording?)
         (start-atomic)
         (set! current-size (add1 current-size))
         (set! procs (cons proc procs))
+        (set! converts (cons convert converts))
         (end-atomic)))
 
-    (define/public (get-recorded-command)
+    (define/public (get-recorded-command [serialize? #f])
       (and (continue-recording?)
+           (if serialize?
+               (for/list ([convert (in-list (reverse converts))])
+                 (convert))
                (let ([procs (reverse procs)])
                  (lambda (dc)
                    (for ([proc (in-list procs)])
-                 (proc dc))))))
+                     (proc dc)))))))
 
     (define/public (reset-recording)
       (start-atomic)
+      (set! clones (make-hasheq))
+      (set! converteds (make-hasheq))
       (set! procs null)
+      (set! converts null)
       (set! current-size 0)
       (end-atomic)
       ;; install current configuration explicitly (so it gets recorded):
@@ -152,18 +404,27 @@
                    [(f) (get-font)]
                    [(tm) (get-text-mode)]
                    [(a) (get-alpha)]
-                   [(cr) (get-clipping-region)])
+                   [(cr) (get-clipping-region)]
+                   [(to-default?) (applies-to-default?)])
+        (when to-default?
           (unless (and (zero? ox) (zero? oy)) (set-origin ox oy))
           (unless (and (= 1 sx) (= 1 sy)) (set-scale sx sy))
           (unless (zero? r) (set-rotation r))
-        (unless (equal? m '#(1.0 0.0 0.0 1.0 0.0 0.0)) (set-initial-matrix m))
+          (unless (equal? m '#(1.0 0.0 0.0 1.0 0.0 0.0)) (set-initial-matrix m)))
+        (unless to-default?
+          (unless (equal? m '#(1.0 0.0 0.0 1.0 0.0 0.0)) (transform m))
+          (unless (zero? r) (rotate r))
+          (unless (and (= 1 sx) (= 1 sy)) (scale sx sy))
+          (unless (and (zero? ox) (zero? oy)) (translate (- sx) (- sy))))
         (do-set-pen! p)
         (do-set-brush! b)
         (set-font f)
-        (unless (eq? s 'unsmoothed) (set-smoothing s))
+        (unless (and to-default? (eq? s 'unsmoothed)) (set-smoothing s))
-        (unless (eq? tm 'transparent) (set-text-mode tm))
+        (unless (and to-default? (eq? tm 'transparent)) (set-text-mode tm))
-        (unless (= a 1.0) (set-alpha a))
+        (unless (and to-default? (= a 1.0)) (set-alpha a))
-        (when cr (set-clipping-region cr))))
+        (unless (and to-default? (not cr)) (set-clipping-region cr))))
+
+    (define/public (applies-to-default?) #t)
 
     (define clones (make-hasheq))
     (define/private (clone clone-x x)
@@ -172,69 +433,20 @@
                  (equal? new-x x)
                  new-x))
           (let ([new-x (clone-x x)])
-            (hash-set! clones x new-x)
+            (when (equal? new-x x)
+              (hash-set! clones x new-x))
             new-x)))
 
-    (define/record (set-scale sx sy))
+    (define converteds (make-hasheq))
+    (define/private (convert convert-x x)
+      (or (hash-ref converteds x #f)
+          (let ([new-x (convert-x x)])
+            (hash-set! converteds x new-x)
+            new-x)))
 
-    (define/record (set-origin sx sy))
+    (define/override (erase)
-    
+      (super erase)
-    (define/record (set-rotation r))
+      (reset-recording))
-
-    (define/override (transform mi)
-      (super transform mi)
-      (when (continue-recording?)
-        (let ([mi (vector->immutable-vector mi)])
-          (record (lambda (dc) (send dc transform mi))))))
-
-    (define/override (set-initial-matrix mi)
-      (super set-initial-matrix mi)
-      (when (continue-recording?)
-        (let ([mi (vector->immutable-vector mi)])
-          (record (lambda (dc) (send dc set-initial-matrix mi))))))
-
-    (define/override (set-transformation mi)
-      (super set-transformation mi)
-      (when (continue-recording?)
-        (let ([mi (vector->immutable-vector mi)])
-          (record (lambda (dc) (send dc set-transformation mi))))))
-
-    (define/record (set-smoothing s))
-
-    (define/record (set-alpha n))
-
-    (define/record (set-font f))
-
-    (define/override (do-set-pen! p)
-      (super do-set-pen! p)
-      (let ([p (clone clone-pen p)])
-        (record (lambda (dc) (send dc do-set-pen! p)))))
-
-    (define/override (do-set-brush! b)
-      (super do-set-brush! b)
-      (when (continue-recording?)
-        (let ([b (clone clone-brush b)])
-          (record (lambda (dc) (send dc do-set-brush! b))))))
-
-    (define/override (set-text-foreground c)
-      (super set-text-foreground c)
-      (when (continue-recording?)
-        (let ([c (clone clone-color c)])
-          (record (lambda (dc) (send dc set-text-foreground c))))))
-    
-    (define/override (set-text-background c)
-      (super set-text-background c)
-      (when (continue-recording?)
-        (let ([c (clone clone-color c)])
-          (record (lambda (dc) (send dc set-text-background c))))))
-    
-    (define/override (set-background c)
-      (super set-background c)
-      (when (continue-recording?)
-        (let ([c (clone clone-color c)])
-          (record (lambda (dc) (send dc set-background c))))))
-    
-    (define/record (set-text-mode m))
 
     (define/override (set-clipping-region r)
       (super set-clipping-region r)
@@ -242,19 +454,51 @@
         (let ([make-r (if r
                           (region-maker r)
                           (lambda (dc) #f))])
-          (record (lambda (dc) (send dc set-clipping-region (make-r dc)))))))
+          (record (lambda (dc) (send dc set-clipping-region (make-r dc)))
+                  (lambda () (list 'set-clipping-region (convert-region r)))))))
+
+    (generate-record-unconvert
+     ([(set-clipping-region) (lambda (r) 
+                               (define make-r (unconvert-region r))
+                               (lambda (dc)
+                                 (send dc set-clipping-region (make-r dc))))])
+     ;; remaining clauses are generated:
+
+     (define/record (set-scale sx sy))
+     
+     (define/record (set-origin sx sy))
+     
+     (define/record (set-rotation r))
+
+     (define/record (transform [mi vector->immutable-vector]))
+
+     (define/record (set-initial-matrix [mi vector->immutable-vector]))
+
+     (define/record (set-transformation [mi vector->immutable-vector]))
+
+     (define/record (set-smoothing s))
+
+     (define/record (set-alpha n))
+
+     (define/record (set-font [f values convert-font unconvert-font]))
+
+     (define/record (do-set-pen! [p clone-pen convert-pen unconvert-pen]))
+
+     (define/record (do-set-brush! [b clone-brush convert-brush unconvert-brush]))
+
+     (define/record (set-text-foreground [c clone-color convert-color unconvert-color]))
+
+     (define/record (set-text-background [c clone-color convert-color unconvert-color]))
+     
+     (define/record (set-background [c clone-color convert-color unconvert-color]))
+     
+     (define/record (set-text-mode m))
 
      (define/record (set-clipping-rect x y w h))
 
      (define/record (clear))
      
-    (define/override (erase)
+     (define/record (draw-arc x y width height start-radians end-radians))
-      (super erase)
-      (reset-recording))
-
-    (define/record (draw-arc x y
-                             width height
-                             start-radians end-radians))
 
      (define/record (draw-ellipse x y w h))
      
@@ -262,48 +506,105 @@
 
      (define/record (draw-point x y))
      
-    (define/override (draw-lines pts [x 0.0] [y 0.0])
+     (define/record (draw-lines [pts clone-points] [[x 0.0]] [[y 0.0]]))
-      (super draw-lines pts x y)
-      (when (continue-recording?)
-        (let ([pts (map (lambda (p) (clone clone-point p)) pts)])
-          (record (lambda (dc) (send dc draw-lines pts x y))))))
 
-    (define/override (draw-polygon pts [x 0.0] [y 0.0] [fill-style 'odd-even])
+     (define/record (draw-polygon [pts clone-points] [[x 0.0]] [[y 0.0]] [[fill-style 'odd-even]]))
-      (super draw-polygon pts x y fill-style)
-      (when (continue-recording?)
-        (let ([pts (map (lambda (p) (clone clone-point p)) pts)])
-          (record (lambda (dc) (send dc draw-polygon pts x y fill-style))))))
 
      (define/record (draw-rectangle x y w h))
      
-    (define/override (draw-rounded-rectangle x y w h [radius -0.25])
+     (define/record (draw-rounded-rectangle x y w h [[radius -0.25]]))
-      (super draw-rounded-rectangle x y w h radius)
-      (record (lambda (dc) (send dc draw-rounded-rectangle x y w h radius))))
 
      (define/record (draw-spline x1 y1 x2 y2 x3 y3))
 
-    (define/override (draw-path path [x 0.0] [y 0.0] [fill-style 'odd-even])
+     (define/record (draw-path [path clone-path convert-path unconvert-path] 
-      (super draw-path path x y fill-style)
+                               [[x 0.0]] [[y 0.0]] [[fill-style 'odd-even]]))
-      (when (continue-recording?)
-        (let ([path (clone clone-path path)])
-          (record (lambda (dc) (send dc draw-path path x y fill-style))))))
      
-    (define/override (draw-text s x y [combine? #f] [offset 0] [angle 0.0])
+     (define/record (draw-text [s string->immutable-string] x y 
-      (super draw-text s x y combine? offset angle)
+                               [[combine? #f]] [[offset 0]] [[angle 0.0]]))
-      (when (continue-recording?)
-        (let ([s (string->immutable-string s)])
-          (record (lambda (dc) (send dc draw-text s x y combine? offset angle))))))
      
-    (define/override (draw-bitmap src dx dy [style 'solid] [color black] [mask #f])
+     (define/record (draw-bitmap [src clone-bitmap convert-bitmap unconvert-bitmap]
-      (super draw-bitmap src dx dy style color mask)
+                                 dx dy [[style 'solid]]
-      (when (continue-recording?)
+                                 [[color black] clone-color convert-color unconvert-color]
-        (let ([src (clone clone-bitmap src)]
+                                 [[mask #f] clone-bitmap convert-bitmap unconvert-bitmap]))
-              [mask (and mask (clone clone-bitmap mask))])
-          (record (lambda (dc) (send dc draw-bitmap src dx dy style color mask))))))
      
-    (define/override (draw-bitmap-section src dx dy sx sy sw sh [style 'solid] [color black] [mask #f])
+     (define/record (draw-bitmap-section [src clone-bitmap convert-bitmap unconvert-bitmap]
-      (super draw-bitmap-section src dx dy sx sy sw sh style color mask)
+                                         dx dy sx sy sw sh [[style 'solid]] 
-      (when (continue-recording?)
+                                         [[color black] clone-color convert-color unconvert-color]
-        (let ([src (clone clone-bitmap src)]
+                                         [[mask #f] clone-bitmap convert-bitmap unconvert-bitmap])))))
-              [mask (and mask (clone clone-bitmap mask))])
+
-          (record (lambda (dc) (send dc draw-bitmap-section src dx dy sx sy sw sh style color mask))))))))
+;; ----------------------------------------
+
+(define record-dc-backend%
+  (class default-dc-backend%
+    (init [[-width width] 640]
+          [[-height height] 480])
+
+    (define-values (width height)
+      (case-args 
+       (list -width -height)
+       [([nonnegative-real? w]
+         [nonnegative-real? h])
+        (values w h)]
+       (init-name 'record-dc%)))
+
+    (define/override (ok?) #t)
+
+    ;; We need a cair context and surface to measure text:
+    (define c (cairo_create (cairo_image_surface_create CAIRO_FORMAT_ARGB32 1 1)))
+    (define/override (get-cr) c)
+
+    (def/override (get-size)
+      (values (exact->inexact width)
+              (exact->inexact height)))
+
+    (super-new)))
+
+(define record-dc%
+  (class (record-dc-mixin (dc-mixin record-dc-backend%))
+    (inherit reset-recording
+             get-recorded-command)
+
+    (define/public (get-recorded-procedure)
+      (get-recorded-command #f))
+
+    (define/public (get-recorded-datum)
+      (get-recorded-command #t))
+
+    (define/override (applies-to-default?) #f)
+    
+    (super-new)
+    (reset-recording)))
+
+(define (recorded-datum->procedure d)
+  (define procs (send (new record-dc%) record-unconvert d))
+  (lambda (dc)
+    (unless (dc . is-a? . dc<%>)
+      (raise-type-error 'recorded-datum->procedure "dc<%> object" dc))
+    ;; save all the existing state:
+    (define-values (ox oy) (send dc get-origin))
+    (define-values (sx sy) (send dc get-scale))
+    (define r (send dc get-rotation))
+    (define m (send dc get-initial-matrix))
+    (define p (send dc get-pen))
+    (define b (send dc get-brush))
+    (define s (send dc get-smoothing))
+    (define f (send dc get-font))
+    (define tm (send dc get-text-mode))
+    (define a (send dc get-alpha))
+    (define cr (send dc get-clipping-region))
+    
+    (for ([proc (in-list procs)])
+      (proc dc))
+    
+    ;; Restore the state:
+    (send dc set-origin ox oy)
+    (send dc set-scale sx sy)
+    (send dc set-rotation r)
+    (send dc set-initial-matrix m)
+    (send dc do-set-pen! p)
+    (send dc do-set-brush! b)
+    (send dc set-font f)
+    (send dc set-smoothing s)
+    (send dc set-text-mode tm)
+    (send dc set-alpha a)
+    (send dc set-clipping-region cr)))

collects/scribblings/draw/bitmap-dc-class.scrbl

@@ -19,7 +19,7 @@ Drawing to a @racket[bitmap-dc%] with a color bitmap is guaranteed to
 
 @defconstructor[([bitmap (or/c (is-a?/c bitmap%) #f)])]{
 
-Creates a new memory DC. If @racket[bitmap] is not @racket[#f], it is
+Creates a new bitmap DC. If @racket[bitmap] is not @racket[#f], it is
  installed into the DC so that drawing commands on the DC draw to
  @racket[bitmap]. Otherwise, no bitmap is installed into the DC and
  @method[bitmap-dc% set-bitmap] must be called before any other method

collects/scribblings/draw/draw-funcs.scrbl

@@ -107,6 +107,11 @@ defaults @racket[kind] and @racket[complain-on-failure?] in a more
 useful way.}
 
 
+@defproc[(recorded-datum->procedure [datum any/c]) ((is-a?/c dc<%>) . -> . void?)]{
+
+Converts a value from @xmethod[record-dc% get-recorded-datum] to a drawing procedure.}
+
+
 @defthing[the-brush-list (is-a?/c brush-list%)]{
 
 See @racket[brush-list%].

collects/scribblings/draw/draw.scrbl

@@ -37,6 +37,7 @@ interface, and procedure bindings defined in this manual.}
 @include-section["post-script-dc-class.scrbl"]
 @include-section["ps-setup-class.scrbl"]
 @include-section["radial-gradient-class.scrbl"]
+@include-section["record-dc-class.scrbl"]
 @include-section["region-class.scrbl"]
 @include-section["svg-dc-class.scrbl"]
 @include-section["draw-funcs.scrbl"]

collects/scribblings/draw/record-dc-class.scrbl

@@ -0,0 +1,37 @@
+#lang scribble/doc
+@(require "common.rkt")
+
+@defclass/title[record-dc% object% (dc<%>)]{
+
+A @racket[record-dc%] object records drawing actions for replay into
+ another drawing context. The recorded drawing operations can be
+ extracted as a procedure via @method[record-dc%
+ get-recorded-procedure], or the actions can be extracted as a datum
+ (that can be printed with @racket[write] and recreated with
+ @racket[read]) via @method[record-dc% get-recorded-datum].
+
+@defconstructor[([width (>=/c 0) 640]
+                 [height (>=/c 0) 480])]{
+
+Creates a new recording DC. The optional @racket[width] and
+ @racket[height] arguments determine the result of @method[dc<%>
+ get-size] on the recording DC; the @racket[width] and
+ @racket[height] arguments do not clip drawing.}
+
+
+@defmethod[(get-recorded-datum) any/c]{
+
+Extracts a recorded drawing to a value that can be printed with
+@racket[write] and re-read with @racket[read]. Use
+@racket[recorded-datum->procedure] to convert the datum to a drawing
+procedure.}
+
+
+@defmethod[(get-recorded-procedure) ((is-a?/c dc<%>) . -> . void?)]{
+
+Extracts a recorded drawing to a procedure that can be applied to
+another DC to replay the drawing commands to the given DC.
+
+The @method[record-dc% get-recorded-procedure] method can be more
+efficient than composing @method[record-dc% get-recorded-datum] and
+@racket[recorded-datum->procedure].}}

collects/tests/gracket/draw.rkt

@@ -220,6 +220,9 @@
        [clock-clip? #f]
        [do-clock #f]
        [use-bitmap? #f]
+       [platform-bitmap? #f]
+       [use-record? #f]
+       [serialize-record? #f]
        [use-bad? #f]
        [depth-one? #f]
        [cyan? #f]
@@ -285,7 +288,11 @@
 		       [bm (if use-bitmap?
 			       (if use-bad?
 				   (make-object bitmap% "no such file")
-				   (make-object bitmap% (* xscale DRAW-WIDTH) (* yscale DRAW-HEIGHT) depth-one?))
+                                   (let ([w (ceiling (* xscale DRAW-WIDTH))]
+                                         [h (ceiling (* yscale DRAW-HEIGHT))])
+                                     (if platform-bitmap?
+                                         (make-platform-bitmap w h)
+                                         (make-object bitmap% w h depth-one?))))
 			       #f)]
 		       [draw-series
 			(lambda (dc pens pent penx size x y flevel last?)
@@ -996,7 +1003,17 @@
 				(send dc draw-rectangle 187 310 20 20)
 				(send dc set-pen p)))
 			      
-			    (when (and last? (not (or kind (eq? dc can-dc)))
+                            (when (and last? use-record?)
+                              (if serialize-record?
+                                  (let ()
+                                    (define-values (i o) (make-pipe))
+                                    (pretty-print (send dc get-recorded-datum))
+                                    (write (send dc get-recorded-datum) o)
+                                    ((recorded-datum->procedure (read i)) can-dc))
+                                  ((send dc get-recorded-procedure) can-dc)))
+
+			    (when (and last? 
+                                       (not (or kind (eq? dc can-dc)))
 				       (send mem-dc get-bitmap))
 			      (send can-dc draw-bitmap (send mem-dc get-bitmap) 0 0 'opaque)))
 			  
@@ -1031,11 +1048,13 @@
                                                     [as-eps (not page?)]
                                                     [use-paper-bbox page?]))])])
 				  (and (send dc ok?) dc))
+                                (if use-record?
+                                    (make-object record-dc% (* xscale DRAW-WIDTH) (* yscale DRAW-HEIGHT))
                                     (if (and use-bitmap?)
                                         (begin
                                           (send mem-dc set-bitmap bm)
                                           mem-dc)
-				    (get-dc)))])
+                                        (get-dc))))])
 		    (when dc
                       (send dc start-doc "Draw Test")
 		      (send dc start-page)
@@ -1205,7 +1224,7 @@
 			(unless (cond
 				 [kind #t]
 				 [use-bad? #t]
-				 [use-bitmap? (and (= w (* xscale DRAW-WIDTH)) (= h (* yscale DRAW-HEIGHT)))]
+				 [use-bitmap? (and (= w (ceiling (* xscale DRAW-WIDTH))) (= h (ceiling (* yscale DRAW-HEIGHT))))]
 				 [else (and (= w (* 2 DRAW-WIDTH)) (= h (* 2 DRAW-HEIGHT)))])
 			  (show-error 'x "wrong size reported by get-size: ~a ~a (not ~a)" w h
                                       (if use-bitmap?
@@ -1230,13 +1249,15 @@
 	    (super-new [parent parent][style '(hscroll vscroll)])
 	    (init-auto-scrollbars (* 2 DRAW-WIDTH) (* 2 DRAW-HEIGHT) 0 0))
 	  vp)])
-    (make-object radio-box% #f '("Canvas" "Pixmap" "Bitmap" "Bad") hp0
+    (make-object choice% #f '("Canvas" "Pixmap" "Bitmap" "Platform" "Record" "Serialize" "Bad") hp0
 		 (lambda (self event)
 		   (set! use-bitmap? (< 0 (send self get-selection)))
 		   (set! depth-one? (< 1 (send self get-selection)))
-		   (set! use-bad? (< 2 (send self get-selection)))
+		   (set! platform-bitmap? (= 3 (send self get-selection)))
-		   (send canvas refresh))
+		   (set! use-record? (<= 4 (send self get-selection) 5))
-		 '(horizontal))
+		   (set! serialize-record? (= 5 (send self get-selection)))
+		   (set! use-bad? (< 5 (send self get-selection)))
+		   (send canvas refresh)))
     (make-object button% "PS" hp
 		 (lambda (self event)
 		   (send canvas on-paint 'ps)))

doc/release-notes/racket/HISTORY.txt

@@ -5,6 +5,7 @@ mysterx: removed ActiveX support plus com-add-ref and
  com-ref-count
 racket/draw: treat a face as a Pango font description
  only when it contains a comma
+racket/draw: add record-dc%
 
 Version 5.2.1.5
 Added racket/future to re-exports of racket