A delegate for dc<%>.

dc-delegate.rkt

#lang racket
(require racket/gui/base)

  
;; Defines a dc<%> implementation that can wrap around
;; another dc.
(define wrapped-dc%
  (class* object% (dc<%>)
    (init-field delegate)
    (super-new)

    ;; This bit of code tries to generate the delegate method
    ;; given the method signature.  It's not quite perfect
    ;; yet because I'm having trouble capturing the re-write rule
    ;; for set-pen and set-brush.
    (define-syntax (write-delegate-method stx)
      (syntax-case stx ()
        [(_ (name args ...))
         (with-syntax ([(arg-ids ...)
                        (for/list ([arg (syntax->list #'(args ...))])
                          (syntax-case arg ()
                            [(id default)
                             #'id]
                            [id
                             #'id]))])
           #'(define/public (name args ...)
               (send delegate name arg-ids ...)))]))

    (define-syntax-rule (write-delegate-methods sig ...)
      (begin (write-delegate-method sig) ...))
    
    
    (write-delegate-methods 
     (cache-font-metrics-key)
     (clear)
     (copy x y width height x2 y2)
     (draw-arc x y width height start-radians end-radians)
     (draw-bitmap source dest-x dest-y 
                  (style 'solid)
                  (color (send the-color-database find-color "black"))
                  (mask #f))
     (draw-bitmap-section source dest-x dest-y src-x src-y 
                          src-width src-height
                          [style 'solid]
                          [color (send the-color-database find-color "black")]
                          [mask #f])
     (draw-ellipse x y width height)
     (draw-line x1 y1 x2 y2)
     (draw-lines points [xoffset 0] [yoffset 0])
     (draw-path path 
                [xoffset 0] [yoffset 0] 
                [fill-style 'odd-even])
     (draw-point x y)
     (draw-polygon points 
                   [xoffset 0] [yoffset 0]
                   [fill-style 'odd-even])
     (draw-rectangle x y width height)
     (draw-rounded-rectangle x y width height [radius -0.25])
     (draw-spline x1 y1 x2 y2 x3 y3)
     (draw-text text x y [combine #f] [offset 0] [angle 0])
     (end-doc)
     (end-page)
     (erase)
     (flush)
     (get-alpha)
     (get-background)
     (get-brush)
     (get-char-height)
     (get-char-width)
     (get-clipping-region)
     (get-device-scale)
     (get-font)
     (get-gl-context)
     (get-initial-matrix)
     (get-origin)
     (get-pen)
     (get-rotation)
     (get-scale)
     (get-size)
     (get-smoothing)
     (get-text-background)
     (get-text-extent string [font #f] [combine? #f] [offset 0])
     (get-text-foreground)
     (get-text-mode)
     (get-transformation)
     (glyph-exists? c)
     (ok?)
     (resume-flush)
     (rotate angle)
     (scale x-scale y-scale)
     (set-alpha opacity)
     (set-background color)
     ;(set-brush brush) ;; fixme: this is not quite right
     (set-clipping-rect x y width height)
     (set-clipping-region rgn)
     (set-font font)
     (set-initial-matrix m)
     (set-origin x y)
     ;(set-pen pen) ;; fixme: this is not quite right
     (set-rotation angle)
     (set-scale x-scale y-scale)
     (set-smoothing mode)
     (set-text-background color)
     (set-text-foreground color)
     (set-text-mode mode)
     (set-transformation t)
     (start-doc message)
     (start-page)
     (suspend-flush)
     (transform m)
     (translate dx dy)
     (try-color try result))

    ;; We'll manually write the methods for set-brush and set-pen
    ;; because they're case-lambdas and a bit unusual, rather
    ;; than complicate the macro any further.
    (public set-brush)
    (define set-brush 
      (case-lambda [(brush)
                    (send delegate set-brush brush)]
                   [(color style)
                    (send delegate set-brush color style)]))
    (public set-pen)
    (define set-pen
      (case-lambda [(pen)
                    (send delegate set-pen pen)]
                   [(color width style)
                    (send delegate set-pen color width style)]))))


(module+ test
  (define bm (make-bitmap 100 100))
  (define my-dc (new wrapped-dc% [delegate (send bm make-dc)]))
  (send my-dc draw-rectangle 10 10 30 50)
  (print bm)
  (newline)
 
  (define extended-dc%
    (class wrapped-dc%
      (super-new)
      (inherit draw-arc)
      (define/public (draw-circle x y radius)
        (draw-arc (- x radius) (- y radius) 
                  (* 2 radius)
                  (* 2 radius)
                  0 
                  (* 2 pi)))))
  
  (define bm2 (make-bitmap 100 100))
  (define my-new-dc (new extended-dc%
                         [delegate (send bm2 make-dc)]))
  (send my-new-dc draw-circle 50 50 30)
  (print bm2))