In Racket, I know how to make my own custom
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
class, I would have to find a way to make
instead of the ordinary
when called with
. Is this possible?
would look something like this (where my defined
is supposed to use the built-in
(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.
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
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))
module at the end here shows that we can wrap a
and extend it as we want.
Racket is supposed to have some built-in support for this in the
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.