Match expanders and color% objects

colors.rkt

#lang racket
(require racket/draw (for-syntax syntax/parse) pict unstable/gui/pict)

(define-syntax defv (make-rename-transformer #'define-values))
(define-syntax defm (make-rename-transformer #'match-define))
(define-syntax def  (make-rename-transformer #'define))

(define-match-expander color:
  (λ (stx) 
    (syntax-parse stx 
      [(_ r g b a)
       #'(or (and (? string?) 
                  (app (λ(s) (def c (send the-color-database find-color s))
                         (list (send c red) (send c green) (send c blue) (send c alpha)))
                       (list r g b a)))
             (and (? object?)
                  (app (λ(c) (list (send c red) (send c green) (send c blue) (send c alpha)))
                       (list r g b a))))])))

(define (color-make r g b α)
  (def (f x) (min 255 (max 0 (exact-floor x))))
  (make-object color% (f r) (f g) (f b) (max 0.0 (min 1.0 α))))

(define (color+ color1 color2)
  (defm (color: r1 g1 b1 α1) color1)
  (defm (color: r2 g2 b2 α2) color2)
  (def (add s t) (min 255 (+ s t)))
  (color-make (add r1 r2) (add g1 g2) (add b1 b2) α1))

(define (color-tuple c)
  (defm (color: r g b α) c)
  (list r g b α))

(define (color* k c)
  (defm (color: r g b α) c)
  (color-make (* k r) (* k g) (* k g) α))

(define (color-med t c1 c2) 
  ; mediate (interpolate) between colors 0<=t<=1
  (color+ (color* t c1) (color* (- 1 t) c2)))

(define (change-red   c r) (defm (color: _ g b α) c) (color-make r g b α))
(define (change-green c g) (defm (color: r _ b α) c) (color-make r g b α))
(define (change-blue  c b) (defm (color: r g _ α) c) (color-make r g b α))
(define (change-alpha c α) (defm (color: r g b _) c) (color-make r g b α))


(for/list ([i (in-range 0 1.1 .1)]) 
  (color (color-med i "red" "blue") (disk 40)))