unstable/gui/blur: added box blur option
This commit is contained in:
Ryan Culpepper
parent
5cf2767e7a
commit
7e1627679c
|
|
@ -10,35 +10,40 @@
|
||||||
slideshow/pict)
|
slideshow/pict)
|
||||||
|
|
||||||
;; TODO: use clipping regions to avoid computing unused pixels
|
;; 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?)))
|
(define nneg-real/c (and/c real? (not/c negative?)))
|
||||||
|
|
||||||
(provide/contract
|
(provide/contract
|
||||||
[blur
|
[blur
|
||||||
(->* (pict? nneg-real/c)
|
(->* (pict? nneg-real/c)
|
||||||
(nneg-real/c)
|
(nneg-real/c
|
||||||
|
#:mode (or/c 'gaussian 'iterated-box 'single-box))
|
||||||
pict?)]
|
pict?)]
|
||||||
[shadow
|
[shadow
|
||||||
(->* (pict? nneg-real/c)
|
(->* (pict? nneg-real/c)
|
||||||
(real? real?
|
(real? real?
|
||||||
#:color (or/c #f string? (is-a?/c color%))
|
#: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?)]
|
pict?)]
|
||||||
[blur-bitmap!
|
[blur-bitmap!
|
||||||
(->* ((is-a?/c bitmap%) exact-nonnegative-integer?)
|
(->* ((is-a?/c bitmap%) exact-nonnegative-integer?)
|
||||||
(exact-nonnegative-integer?)
|
(exact-nonnegative-integer?
|
||||||
|
#:mode (or/c 'gaussian 'iterated-box 'single-box))
|
||||||
void?)])
|
void?)])
|
||||||
|
|
||||||
;; ----
|
;; ----
|
||||||
|
|
||||||
(define (blur p hbr [vbr hbr] #:auto-inset? [auto-inset? #f])
|
(define (blur p hbr [vbr hbr] #:mode [mode 'iterated-box] #:auto-inset? [auto-inset? #f])
|
||||||
(let ([blurred (*blur (inset p hbr vbr) hbr vbr)])
|
(let ([blurred (*blur (inset p hbr vbr) hbr vbr mode)])
|
||||||
(cond [auto-inset? blurred]
|
(cond [auto-inset? blurred]
|
||||||
[else (inset blurred (- hbr) (- vbr))])))
|
[else (inset blurred (- hbr) (- vbr))])))
|
||||||
|
|
||||||
(define (shadow p br [dx 0] [dy dx]
|
(define (shadow p br [dx 0] [dy dx]
|
||||||
#:color [c #f]
|
#:color [c #f]
|
||||||
#:shadow-color [shc #f]
|
#:shadow-color [shc #f]
|
||||||
|
#:mode [mode 'iterated-box]
|
||||||
#:auto-inset? [auto-inset? #f])
|
#:auto-inset? [auto-inset? #f])
|
||||||
;; FIXME: should auto-inset also use dx, dy?
|
;; FIXME: should auto-inset also use dx, dy?
|
||||||
(define (colorize* p c)
|
(define (colorize* p c)
|
||||||
|
|
@ -46,21 +51,20 @@
|
||||||
(let ([result
|
(let ([result
|
||||||
(pin-under (colorize* p c)
|
(pin-under (colorize* p c)
|
||||||
dx dy
|
dx dy
|
||||||
(blur (colorize* p shc) br))])
|
(blur (colorize* p shc) br #:mode mode))])
|
||||||
(cond [auto-inset? (inset result br)]
|
(cond [auto-inset? (inset result br)]
|
||||||
[else result])))
|
[else result])))
|
||||||
|
|
||||||
(define (blur-bitmap! bmp hbr [vbr hbr])
|
(define (blur-bitmap! bmp hbr [vbr hbr] #:mode [mode 'iterated-box])
|
||||||
(let ([h-cvec (gaussian-cvec hbr)]
|
(blur! bmp hbr vbr mode))
|
||||||
[v-cvec (gaussian-cvec vbr)])
|
|
||||||
(blur! bmp h-cvec v-cvec)))
|
|
||||||
|
|
||||||
;; ----
|
;; ----
|
||||||
|
|
||||||
(define MAX-RADIUS (expt 2 10))
|
(define MAX-RADIUS (expt 2 10))
|
||||||
(define MAX-WEIGHT (expt 2 5))
|
(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)]
|
(let* ([w (pict-width p)]
|
||||||
[h (pict-height p)]
|
[h (pict-height p)]
|
||||||
[drawer (make-pict-drawer p)])
|
[drawer (make-pict-drawer p)])
|
||||||
|
|
@ -68,8 +72,8 @@
|
||||||
(let-values ([(sx sy) (send dc get-scale)])
|
(let-values ([(sx sy) (send dc get-scale)])
|
||||||
(let* ([pxw (ceil/e (* w sx))]
|
(let* ([pxw (ceil/e (* w sx))]
|
||||||
[pxh (ceil/e (* h sy))]
|
[pxh (ceil/e (* h sy))]
|
||||||
[h-cvec (gaussian-cvec (min (ceil/e (* hbr sx)) pxw MAX-RADIUS))]
|
[hbr* (min (ceil/e (* hbr sx)) pxw MAX-RADIUS)]
|
||||||
[v-cvec (gaussian-cvec (min (ceil/e (* vbr sy)) pxh MAX-RADIUS))]
|
[vbr* (min (ceil/e (* vbr sy)) pxh MAX-RADIUS)]
|
||||||
[bmp (make-object bitmap% pxw pxh #f #t)]
|
[bmp (make-object bitmap% pxw pxh #f #t)]
|
||||||
[bdc (new bitmap-dc% (bitmap bmp))])
|
[bdc (new bitmap-dc% (bitmap bmp))])
|
||||||
(send bdc set-scale sx sy)
|
(send bdc set-scale sx sy)
|
||||||
|
|
@ -78,20 +82,36 @@
|
||||||
(send bdc set-brush (send dc get-brush))
|
(send bdc set-brush (send dc get-brush))
|
||||||
(send bdc set-text-foreground (send dc get-text-foreground))
|
(send bdc set-text-foreground (send dc get-text-foreground))
|
||||||
(drawer bdc 0 0)
|
(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 set-scale 1.0 1.0)
|
||||||
(send dc draw-bitmap bmp (* x sx) (* y sy))
|
(send dc draw-bitmap bmp (* x sx) (* y sy))
|
||||||
(send dc set-scale sx sy))))
|
(send dc set-scale sx sy))))
|
||||||
w h)))
|
w h)))
|
||||||
|
|
||||||
(define (blur! bmp h-cvec v-cvec)
|
(define (blur! bmp hbr vbr mode)
|
||||||
(let* ([w (send bmp get-width)]
|
(let* ([w (send bmp get-width)]
|
||||||
[h (send bmp get-height)]
|
[h (send bmp get-height)]
|
||||||
[pix (make-bytes (* w h 4))]
|
[pix (make-bytes (* w h 4))]
|
||||||
[out (make-bytes (* w h 4))])
|
[out (make-bytes (* w h 4))])
|
||||||
(send bmp get-argb-pixels 0 0 w h pix #f #t)
|
(send bmp get-argb-pixels 0 0 w h pix #f #t)
|
||||||
|
(case mode
|
||||||
|
((gaussian)
|
||||||
|
(let* ([h-cvec (gaussian-cvec hbr)]
|
||||||
|
[v-cvec (gaussian-cvec vbr)])
|
||||||
(convolve-h pix out h-cvec w h)
|
(convolve-h pix out h-cvec w h)
|
||||||
(convolve-v out pix v-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)
|
(send bmp set-argb-pixels 0 0 w h pix #f #t)
|
||||||
(void)))
|
(void)))
|
||||||
|
|
||||||
|
|
@ -163,13 +183,88 @@
|
||||||
[else
|
[else
|
||||||
(ceil/e (* MAX-WEIGHT (G (/ (* 3 sigma (- x radius)) radius))))])))]))
|
(ceil/e (* MAX-WEIGHT (G (/ (* 3 sigma (- x radius)) radius))))])))]))
|
||||||
|
|
||||||
#|
|
;; ----
|
||||||
(define (linear-cvec w0 hi lo)
|
|
||||||
(let ([hw (quotient w0 2)])
|
;; iterated box blur
|
||||||
(build-vector (+ 1 hw hw)
|
|
||||||
(lambda (x)
|
(define (box-line* radius start end get-val set-val)
|
||||||
(ceil/e (+ lo (* (- 1 (/ (abs (- x hw)) hw)) (- hi lo))))))))
|
(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*))))))
|
||||||
|
|
||||||
;; ----
|
;; ----
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -21,17 +21,28 @@
|
||||||
|
|
||||||
@defproc[(blur [p pict?]
|
@defproc[(blur [p pict?]
|
||||||
[h-radius (and/c real? (not/c negative?))]
|
[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?]{
|
pict?]{
|
||||||
|
|
||||||
Applies a gaussian blur to @racket[p]. The blur radii,
|
Blurs @racket[p] using a gaussian blur (if @racket[mode] is
|
||||||
@racket[h-radius] and @racket[v-radius], control the blurriness of the
|
@racket['gaussian]), an iterated box blur that approximates a gaussian
|
||||||
resulting pict.
|
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))]
|
@racketblock[(* (pict-width p) (pict-height p) (+ h-radius v-radius))]
|
||||||
although it may be sped up by a factor of up to
|
The @racket['iterated-box] blur mode is much faster; it takes work
|
||||||
@racket[(processor-count)] due to its use of @racket[future]s.
|
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
|
@examples[#:eval the-eval
|
||||||
(blur (text "blur" null 40) 5)
|
(blur (text "blur" null 40) 5)
|
||||||
|
|
@ -45,15 +56,22 @@ the pict should be @racket[inset] by the blur radius.
|
||||||
@examples[#:eval the-eval
|
@examples[#:eval the-eval
|
||||||
(inset (blur (text "more blur" null 40) 10) 10)
|
(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%)]
|
@defproc[(blur-bitmap! [bitmap (is-a?/c bitmap%)]
|
||||||
[h-radius (and/c real? (not/c negative?))]
|
[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?]{
|
void?]{
|
||||||
|
|
||||||
Blurs @racket[bitmap] using blur radii @racket[h-radius] and
|
Blurs @racket[bitmap] using blur radii @racket[h-radius] and
|
||||||
@racket[v-radius].
|
@racket[v-radius] and mode @racket[mode].
|
||||||
}
|
}
|
||||||
|
|
||||||
@defproc[(shadow [p pict?]
|
@defproc[(shadow [p pict?]
|
||||||
|
|
@ -61,7 +79,8 @@ Blurs @racket[bitmap] using blur radii @racket[h-radius] and
|
||||||
[dx real? 0]
|
[dx real? 0]
|
||||||
[dy real? dx]
|
[dy real? dx]
|
||||||
[#:color color (or/c #f string? (is-a?/c color%)) #f]
|
[#: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?]{
|
pict?]{
|
||||||
|
|
||||||
Creates a shadow effect by superimposing @racket[p] over a
|
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.
|
(@racket[dx], @racket[dy]) units.
|
||||||
|
|
||||||
If @racket[color] is not @racket[#f], the foreground part is
|
If @racket[color] is not @racket[#f], the foreground part is
|
||||||
@racket[(colorize p color)] instead. If @racket[shadow-color] is not
|
@racket[(colorize p color)]; otherwise it is just @racket[p]. If
|
||||||
@racket[#f], the shadow part is produced by blurring @racket[(colorize p
|
@racket[shadow-color] is not @racket[#f], the shadow part is produced
|
||||||
shadow-color)].
|
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].
|
The resulting pict has the same bounding box as @racket[p].
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user