[racket] Drawing a gradient on text

I guess I've been waiting for a reason to sort out text paths. The
`dc-path%' class now has a `text-outline' method (as of the latest in
the git repo).

At Sun, 25 Dec 2011 00:00:44 -0700, Michael W wrote:
> Merry Christmas, Racketeers!
> 
> Is there an easy way to draw text to a bitmap% with a gradient?
> 
> I briefly looked into adding linear-gradient% and
> radial-gradient% support to slideshow/pict but unfortunately we
> can't draw text using an arbitrary brush% as the draw-text method
> of dc% ignores that.
> 
> My current trick is to draw the gradient to one bitmap, draw the
> text to another bitmap, and then draw the first bitmap to a third
> bitmap while copying the mask of the second. Is there a better
> way?
> 
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> #lang racket
> (require slideshow/pict
>          racket/draw)
> 
> (define (compose-picts base alpha)
>   ;; Return a bitmap% with the colors of base but the alpha of alpha.
>   (define-values (w h)
>     (values (inexact->exact (ceiling (pict-width base)))
>             (inexact->exact (ceiling (pict-height base)))))
>   (define-values (base-bitmap alpha-bitmap final-bitmap)
>     (values (make-bitmap w h)
>             (make-bitmap w h)
>             (make-bitmap w h)))
>   (define-values (base-dc alpha-dc final-dc)
>     (apply values (map (λ(bm) (new bitmap-dc% [bitmap bm]))
>                        (list base-bitmap alpha-bitmap final-bitmap))))
>   (send base-dc set-smoothing 'aligned)
>   (draw-pict base base-dc 0 0)
>   (send alpha-dc set-smoothing 'aligned)
>   (draw-pict alpha alpha-dc 0 0)
>   (send final-dc draw-bitmap base-bitmap 0 0 'solid #f alpha-bitmap)
>   final-bitmap)
> 
> ;; The text to render
> (define my-text
>   (scale (text "Hello World") 4))
> 
> ;; The linear-gradient% to render
> (define gradient
>   (new linear-gradient% [x0 0] [y0 0] [x1 0] [y1 (pict-height my-text)]
>        [stops (list (list 0.0 (make-object color% 0 0 0))
>                     (list 1.0 (make-object color% 255 0 0)))]))
> 
> ;; A box containing the gradient
> (define gradient-box
>   (dc
>    (λ(dc w h)
>      (send dc set-pen (make-object pen% "white" 1 'transparent))
>      (send dc set-brush (new brush% [gradient gradient]))
>      (send dc draw-rectangle
>            0 0 (pict-width my-text) (pict-height my-text)))
>    (pict-width my-text) (pict-height my-text)))
> 
> ;; The final result: Gradient-filled text!
> (bitmap (compose-picts gradient-box my-text))
> 
> -- 
> Heave ho,
>     _mike