Drawing partly-rounded-rectangles using Racket's path support

draw-partly-rounded-shape.rkt

#lang send-exp racket

(require racket/draw)

(define-syntax-rule (build-path (p) body ...)
  (let ((p (new dc-path%)))
    body ...
    p))

(define (quarter-circle p cx cy quarter radius)
  {arc p
       (- cx radius)
       (- cy radius)
       (* radius 2)
       (* radius 2)
       (* pi quarter 1/2)
       (* pi (+ 1 quarter) 1/2)})

(define (draw-it dc)
  (define corner-radius 20)
  (define top 20)
  (define left 20)
  (define bottom 100)
  (define right 200)
  (send dc draw-path
        (build-path (p)
                    {move-to p left (+ top corner-radius)}
                    {line-to p left bottom}
                    {line-to p right bottom}
                    {line-to p right (+ top corner-radius)}
                    (quarter-circle p (- right corner-radius) (+ top corner-radius) 0 corner-radius)
                    {line-to p (+ left corner-radius) top}
                    (quarter-circle p (+ left corner-radius) (+ top corner-radius) 1 corner-radius)
                    )))

(define bm (make-bitmap 300 300))
(define dc (new bitmap-dc% [bitmap bm]))
(send dc set-smoothing 'smoothed)
(send dc set-pen "black" 1 'solid)
(send dc set-brush "yellow" 'solid)
(draw-it dc)
bm