51 lines
1.5 KiB
Scheme
51 lines
1.5 KiB
Scheme
|
|
(module flash mzscheme
|
|
(require "mrpict.ss"
|
|
(lib "math.ss")
|
|
(lib "etc.ss")
|
|
(lib "mred.ss" "mred")
|
|
(lib "class.ss"))
|
|
|
|
(provide filled-flash
|
|
outline-flash)
|
|
|
|
(define-syntax define-flash
|
|
(syntax-rules ()
|
|
[(_ id filled?)
|
|
(define id
|
|
(opt-lambda (w h [points 10] [spike-fraction 0.25] [rotation 0])
|
|
(do-flash filled? w h points spike-fraction rotation)))]))
|
|
|
|
(define-flash filled-flash #t)
|
|
(define-flash outline-flash #f)
|
|
|
|
(define no-brush
|
|
(send the-brush-list find-or-create-brush "white" 'transparent))
|
|
|
|
(define do-flash
|
|
(lambda (filled? w h points spike-fraction rotation)
|
|
(let ([p (new dc-path%)]
|
|
[delta (/ pi points)]
|
|
[in (- 1 spike-fraction)])
|
|
(send p move-to 1 0)
|
|
(let loop ([angle delta][points (sub1 points)])
|
|
(send p line-to (* in (cos angle)) (* in (sin angle)))
|
|
(unless (zero? points)
|
|
(let ([angle (+ angle delta)])
|
|
(send p line-to (cos angle) (sin angle))
|
|
(loop (+ angle delta) (sub1 points)))))
|
|
(send p close)
|
|
(send p scale (/ w 2) (/ h 2))
|
|
(unless (zero? rotation)
|
|
(send p rotate rotation))
|
|
(let-values ([(bx by bw bh) (send p get-bounding-box)])
|
|
(send p translate (- bx) (- by))
|
|
(dc (lambda (dc x y)
|
|
(let ([b (or filled? (send dc get-brush))])
|
|
(unless filled?
|
|
(send dc set-brush no-brush))
|
|
(send dc draw-path p x y)
|
|
(unless filled?
|
|
(send dc set-brush b))))
|
|
bw bh))))))
|