Define custom methods of drawing context for canvas

Question

In Racket, I know how to make my own custom canvas% class with its own on-event method:

(define my-canvas%
  (class canvas%
    (define/override (on-event event)
      (cond ...));; handle the event
    (super-new)))

I would like to make a similar change to the drawing context returned by (send canvas get-dc) so that it has more drawing methods. If I make a custom my-dc% class, I would have to find a way to make my-canvas% return it instead of the ordinary dc% when called with get-dc. Is this possible?

More specifically, my-dc% would look something like this (where my defined draw-circle is supposed to use the built-in draw-arc):

(define my-dc%
  (class dc%
    (define (draw-circle x y radius)
      (draw-arc (- x radius) ; left
                (- y radius) ; top
                (* 2 radius) ; width
                (* 2 radius) ; height
                0            ; start-angle
                (* 2 pi)))   ; end-angle
    (super-new)))

so that I can later do just (send dc draw-circle 100 100 20) to draw a circle, like every other drawing method.

Answer 1

You can probably write a container that delegates most of the work off to the contained dc%. You could do something like this:

#lang racket
(require racket/gui/base)

(define my-dc%
  (class* object% (dc<%>)
    (init-field delegate)
    (super-new)

    (define/public (cache-font-metrics-key)
      (send delegate cache-font-metrics-key))

    (define/public (clear)
      (send delegate clear))

    (define/public (copy x y width height x2 y2)
      (send delegate copy x y width height x2 y2))

    (define/public (draw-arc x y width height start-radians end-radians)
      (send delegate draw-arc x y width height start-radians end-radians))

    ;; FILL ME IN...
))

going through all the methods listed in the dc<%> interface. This approach is admittedly pretty brute force, but it should work. Then you could add whatever extra methods you wanted to this class, since it's yours.

Here is a complete example, using some macros to reduce a bunch of the copy-and-pasting I'd otherwise do:

#lang racket
(require racket/gui/base)


;; Defines a dc<%> implementation that can wrap around
;; another dc.
;; 
;; Can also be found at: https://gist.github.com/dyoo/5025445
;;
;; The test code near the bottom shows an example
;; of how to use the delegate.


(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 set-smoothing 'aligned)
  (send my-new-dc draw-circle 50 50 30)
  (print bm2))

The test module at the end here shows that we can wrap a dc and extend it as we want.

Racket is supposed to have some built-in support for this in the surrogate form, though I have to admit I haven't tried it yet. If I have time, I'll try to cook up an example and revise this answer if it's an improvement over the above.

Answer 2

No, I don't think it's possible to change the class of dc<%> that a canvas uses, based on a look at both the documentation and the source code.

You'll have to make draw-circle a function instead:

(define (draw-circle dc x y radius)
  (send dc draw-arc ....))