From 7e1627679c6c6ad8670c64cc1a30de13b36387ab Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Mon, 18 Jul 2011 07:19:41 -0600 Subject: [PATCH] unstable/gui/blur: added box blur option --- collects/unstable/gui/blur.rkt | 145 +++++++++++++++---- collects/unstable/scribblings/gui/blur.scrbl | 46 ++++-- 2 files changed, 153 insertions(+), 38 deletions(-) diff --git a/collects/unstable/gui/blur.rkt b/collects/unstable/gui/blur.rkt index c754af5c65..157df35c8f 100644 --- a/collects/unstable/gui/blur.rkt +++ b/collects/unstable/gui/blur.rkt @@ -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*)))))) ;; ---- diff --git a/collects/unstable/scribblings/gui/blur.scrbl b/collects/unstable/scribblings/gui/blur.scrbl index a95ad8dd4e..975a442b21 100644 --- a/collects/unstable/scribblings/gui/blur.scrbl +++ b/collects/unstable/scribblings/gui/blur.scrbl @@ -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].