suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

unstable/gui/blur: added box blur option

Browse Source
This commit is contained in:
Ryan Culpepper 2011-07-18 07:19:41 -06:00
parent 5cf2767e7a
commit 7e1627679c
2 changed files with 153 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

145
collects/unstable/gui/blur.rkt
View File

@ -10,35 +10,40 @@
slideshow/pict)
;; TODO: use clipping regions to avoid computing unused pixels
;; TODO: tweak parameters so that gaussian and iterated-box modes are closer
(define nneg-real/c (and/c real? (not/c negative?)))
(provide/contract
[blur
(->* (pict? nneg-real/c)
(nneg-real/c)
(nneg-real/c
#:mode (or/c 'gaussian 'iterated-box 'single-box))
pict?)]
[shadow
(->* (pict? nneg-real/c)
(real? real?
#:color (or/c #f string? (is-a?/c color%))
#:shadow-color (or/c #f string? (is-a?/c color%)))
#:shadow-color (or/c #f string? (is-a?/c color%))
#:mode (or/c 'gaussian 'iterated-box 'single-box))
pict?)]
[blur-bitmap!
(->* ((is-a?/c bitmap%) exact-nonnegative-integer?)
(exact-nonnegative-integer?)
(exact-nonnegative-integer?
#:mode (or/c 'gaussian 'iterated-box 'single-box))
void?)])
;; ----
(define (blur p hbr [vbr hbr] #:auto-inset? [auto-inset? #f])
(let ([blurred (*blur (inset p hbr vbr) hbr vbr)])
(define (blur p hbr [vbr hbr] #:mode [mode 'iterated-box] #:auto-inset? [auto-inset? #f])
(let ([blurred (*blur (inset p hbr vbr) hbr vbr mode)])
(cond [auto-inset? blurred]
[else (inset blurred (- hbr) (- vbr))])))
(define (shadow p br [dx 0] [dy dx]
#:color [c #f]
#:shadow-color [shc #f]
#:mode [mode 'iterated-box]
#:auto-inset? [auto-inset? #f])
;; FIXME: should auto-inset also use dx, dy?
(define (colorize* p c)
@ -46,21 +51,20 @@
(let ([result
(pin-under (colorize* p c)
dx dy
(blur (colorize* p shc) br))])
(blur (colorize* p shc) br #:mode mode))])
(cond [auto-inset? (inset result br)]
[else result])))
(define (blur-bitmap! bmp hbr [vbr hbr])
(let ([h-cvec (gaussian-cvec hbr)]
[v-cvec (gaussian-cvec vbr)])
(blur! bmp h-cvec v-cvec)))
(define (blur-bitmap! bmp hbr [vbr hbr] #:mode [mode 'iterated-box])
(blur! bmp hbr vbr mode))
;; ----
(define MAX-RADIUS (expt 2 10))
(define MAX-WEIGHT (expt 2 5))
(define BOX-ITERATIONS 3)
(define (*blur p hbr vbr)
(define (*blur p hbr vbr mode)
(let* ([w (pict-width p)]
[h (pict-height p)]
[drawer (make-pict-drawer p)])
@ -68,8 +72,8 @@
(let-values ([(sx sy) (send dc get-scale)])
(let* ([pxw (ceil/e (* w sx))]
[pxh (ceil/e (* h sy))]
[h-cvec (gaussian-cvec (min (ceil/e (* hbr sx)) pxw MAX-RADIUS))]
[v-cvec (gaussian-cvec (min (ceil/e (* vbr sy)) pxh MAX-RADIUS))]
[hbr* (min (ceil/e (* hbr sx)) pxw MAX-RADIUS)]
[vbr* (min (ceil/e (* vbr sy)) pxh MAX-RADIUS)]
[bmp (make-object bitmap% pxw pxh #f #t)]
[bdc (new bitmap-dc% (bitmap bmp))])
(send bdc set-scale sx sy)
@ -78,20 +82,36 @@
(send bdc set-brush (send dc get-brush))
(send bdc set-text-foreground (send dc get-text-foreground))
(drawer bdc 0 0)
(blur! bmp h-cvec v-cvec)
(blur! bmp hbr* vbr* mode)
(send dc set-scale 1.0 1.0)
(send dc draw-bitmap bmp (* x sx) (* y sy))
(send dc set-scale sx sy))))
w h)))
(define (blur! bmp h-cvec v-cvec)
(define (blur! bmp hbr vbr mode)
(let* ([w (send bmp get-width)]
[h (send bmp get-height)]
[pix (make-bytes (* w h 4))]
[out (make-bytes (* w h 4))])
(send bmp get-argb-pixels 0 0 w h pix #f #t)
(convolve-h pix out h-cvec w h)
(convolve-v out pix v-cvec w h)
(case mode
((gaussian)
(let* ([h-cvec (gaussian-cvec hbr)]
[v-cvec (gaussian-cvec vbr)])
(convolve-h pix out h-cvec w h)
(convolve-v out pix v-cvec w h)))
((single-box)
(box-h pix out hbr w h 1)
(box-v out pix vbr w h 1))
((iterated-box)
(let ([hbr (ceil/e (/ hbr BOX-ITERATIONS))]
[vbr (ceil/e (/ vbr BOX-ITERATIONS))])
(box-h pix out hbr w h BOX-ITERATIONS)
(let-values ([(pix* out*)
(cond [(even? BOX-ITERATIONS) (values out pix)]
[else (values pix out)])])
(box-v pix* out* vbr w h BOX-ITERATIONS))))
(else (error 'blur! "bad mode")))
(send bmp set-argb-pixels 0 0 w h pix #f #t)
(void)))
@ -144,7 +164,7 @@
(bytes-set! out (unsafe-fx+ (unsafe-fx* 4 (unsafe-fx+ (unsafe-fx* w i) col)) offset) v))
(for/async ([col (in-range w)])
(convolve-line* cvec 0 h (mkget col) (mkset col))))
(define (gaussian-cvec radius [bias 'none]) ;; .84
(define sigma 1)
(define (G x)
@ -163,13 +183,88 @@
[else
(ceil/e (* MAX-WEIGHT (G (/ (* 3 sigma (- x radius)) radius))))])))]))
#|
(define (linear-cvec w0 hi lo)
(let ([hw (quotient w0 2)])
(build-vector (+ 1 hw hw)
(lambda (x)
(ceil/e (+ lo (* (- 1 (/ (abs (- x hw)) hw)) (- hi lo))))))))
|#
;; ----
;; iterated box blur
(define (box-line* radius start end get-val set-val)
(let ([non-zero-alpha?
(for/or ([outi (in-range start end)])
(positive? (get-val outi 0)))])
(cond [non-zero-alpha?
(for/fold ([wA 0] [wR 0] [wG 0] [wB 0] [wW 0])
([leadI (in-range start (+ end radius))])
;; (eprintf "leadI = ~s, wA = ~s, wW = ~s\n" leadI wA wW)
(let*-values ([(outI) (unsafe-fx- leadI radius)]
[(tailI) (unsafe-fx- leadI (unsafe-fx+ radius radius))]
[(addA addR addG addB addW)
(cond [(unsafe-fx< leadI end)
(values (get-val leadI 0)
(get-val leadI 1)
(get-val leadI 2)
(get-val leadI 3)
1)]
[else (values 0 0 0 0 0)])]
[(dropA dropR dropG dropB dropW)
(cond [(unsafe-fx>= tailI start)
(values (get-val tailI 0)
(get-val tailI 1)
(get-val tailI 2)
(get-val tailI 3)
1)]
[else (values 0 0 0 0 0)])]
[(nwA) (unsafe-fx+ wA addA)]
[(nwR) (unsafe-fx+ wR addR)]
[(nwG) (unsafe-fx+ wG addG)]
[(nwB) (unsafe-fx+ wB addB)]
[(nwW) (unsafe-fx+ wW addW)])
(when (and (unsafe-fx>= outI start) (unsafe-fx< outI end))
;; (eprintf "setting ~a = (~a,...)\n" outI (quotient nwA nwW))
(set-val outI 0 (unsafe-fxquotient nwA nwW))
(set-val outI 1 (unsafe-fxquotient nwR nwW))
(set-val outI 2 (unsafe-fxquotient nwG nwW))
(set-val outI 3 (unsafe-fxquotient nwB nwW)))
(values (unsafe-fx- nwA dropA)
(unsafe-fx- nwR dropR)
(unsafe-fx- nwG dropG)
(unsafe-fx- nwB dropB)
(unsafe-fx- nwW dropW))))]
[else
(for ([outI (in-range start end)])
(set-val outI 0 0)
(set-val outI 1 0)
(set-val outI 2 0)
(set-val outI 3 0))])))
(define (box-h in out radius w h iterations)
(define (get-val i offset) (bytes-ref in (unsafe-fx+ offset (unsafe-fx* 4 i))))
(define (set-val i offset v) (bytes-set! out (unsafe-fx+ offset (unsafe-fx* 4 i)) v))
(define (get-val* i offset) (bytes-ref out (unsafe-fx+ offset (unsafe-fx* 4 i))))
(define (set-val* i offset v) (bytes-set! in (unsafe-fx+ offset (unsafe-fx* 4 i)) v))
(for/async ([row (in-range h)])
(for ([iter (in-range iterations)])
(box-line* radius (* row w) (* (add1 row) w)
(if (even? iter) get-val get-val*)
(if (even? iter) set-val set-val*)))))
(define (box-v in out radius w h iterations)
(define ((mkget col) i offset)
(bytes-ref in (unsafe-fx+ (unsafe-fx* 4 (unsafe-fx+ (unsafe-fx* w i) col)) offset)))
(define ((mkset col) i offset v)
(bytes-set! out (unsafe-fx+ (unsafe-fx* 4 (unsafe-fx+ (unsafe-fx* w i) col)) offset) v))
(define ((mkget* col) i offset)
(bytes-ref out (unsafe-fx+ (unsafe-fx* 4 (unsafe-fx+ (unsafe-fx* w i) col)) offset)))
(define ((mkset* col) i offset v)
(bytes-set! in (unsafe-fx+ (unsafe-fx* 4 (unsafe-fx+ (unsafe-fx* w i) col)) offset) v))
(for/async ([col (in-range w)])
(let ([get (mkget col)]
[get* (mkget* col)]
[set (mkset col)]
[set* (mkset* col)])
(for ([iter (in-range iterations)])
(box-line* radius 0 h
(if (even? iter) get get*)
(if (even? iter) set set*))))))
;; ----

46
collects/unstable/scribblings/gui/blur.scrbl
View File

@ -21,17 +21,28 @@
@defproc[(blur [p pict?]
[h-radius (and/c real? (not/c negative?))]
[v-radius (and/c real? (not/c negative?)) h-radius])
[v-radius (and/c real? (not/c negative?)) h-radius]
[#:mode mode (or/c 'gaussian 'iterated-box 'single-box) 'iterated-box])
pict?]{
Applies a gaussian blur to @racket[p]. The blur radii,
@racket[h-radius] and @racket[v-radius], control the blurriness of the
resulting pict.
Blurs @racket[p] using a gaussian blur (if @racket[mode] is
@racket['gaussian]), an iterated box blur that approximates a gaussian
blur (if @racket[mode] is @racket['iterated-box]), or a single box
blur (if @racket[mode] is @racket['single-box]). The @racket[h-radius]
and @racket[v-radius] arguments control the strength of the horizontal
and vertical components of the blur, respectively. They are given in
terms of pict units, which may not directly correspond to screen pixels.
Note: blurring is fairly slow. It takes time proportional to
The @racket['gaussian] blur mode is quite slow for large blur
radii. It takes work proportional to
@racketblock[(* (pict-width p) (pict-height p) (+ h-radius v-radius))]
although it may be sped up by a factor of up to
@racket[(processor-count)] due to its use of @racket[future]s.
The @racket['iterated-box] blur mode is much faster; it takes work
proportional to
@racketblock[(* (pict-width p) (pict-height p))]
The genuine @racket['gaussian] mode generally produces smoother and
lighter images, but the @racket['iterated-box] approximation is
acceptable for most uses. All modes may be sped up by a factor of up
to @racket[(processor-count)] due to the use of @racket[future]s.
@examples[#:eval the-eval
(blur (text "blur" null 40) 5)
@ -45,15 +56,22 @@ the pict should be @racket[inset] by the blur radius.
@examples[#:eval the-eval
(inset (blur (text "more blur" null 40) 10) 10)
]
Genuine @racket['gaussian] blur compared with @racket['iterated-box] blur:
@examples[#:eval the-eval
(vl-append (inset (blur (text "blur" null 40) 10 #:mode 'gaussian) 10)
(inset (blur (text "blur" null 40) 10 #:mode 'iterated-box) 10))
]
}
@defproc[(blur-bitmap! [bitmap (is-a?/c bitmap%)]
[h-radius (and/c real? (not/c negative?))]
[v-radius (and/c real? (not/c negative?)) h-radius])
[v-radius (and/c real? (not/c negative?)) h-radius]
[#:mode mode (or/c 'gaussian 'iterated-box 'single-box) 'iterated-box])
void?]{
Blurs @racket[bitmap] using blur radii @racket[h-radius] and
@racket[v-radius].
@racket[v-radius] and mode @racket[mode].
}
@defproc[(shadow [p pict?]
@ -61,7 +79,8 @@ Blurs @racket[bitmap] using blur radii @racket[h-radius] and
[dx real? 0]
[dy real? dx]
[#:color color (or/c #f string? (is-a?/c color%)) #f]
[#:shadow-color shadow-color (or/c #f string? (is-a?/c color%)) #f])
[#:shadow-color shadow-color (or/c #f string? (is-a?/c color%)) #f]
[#:mode mode (or/c 'gaussian 'iterated-box 'single-box) 'iterated-box])
pict?]{
Creates a shadow effect by superimposing @racket[p] over a
@ -69,9 +88,10 @@ blurred version of @racket[p]. The shadow is offset from @racket[p] by
(@racket[dx], @racket[dy]) units.
If @racket[color] is not @racket[#f], the foreground part is
@racket[(colorize p color)] instead. If @racket[shadow-color] is not
@racket[#f], the shadow part is produced by blurring @racket[(colorize p
shadow-color)].
@racket[(colorize p color)]; otherwise it is just @racket[p]. If
@racket[shadow-color] is not @racket[#f], the shadow part is produced
by blurring @racket[(colorize p shadow-color)]; otherwise it is
produced by blurring @racket[p].
The resulting pict has the same bounding box as @racket[p].