[racket] flood-fill?

Is it in the package catalog?

Vincent


At Sat, 11 Oct 2014 20:59:09 +0200,
Pierpaolo Bernardi wrote:
> 
> For the record, in case someone else needs a flood-fill, attached
> below there's what I ended up using.
> 
> With respect to the GitHub version (which uses an implicit stack) this
> one uses a queue for storing the restart points.  This probably is
> slower but it uses much less memory (proportional to the length of the
> frontier of the expanding paint rather than proportional to the area
> to be painted). I used it for filling areas of around 100M pixels with
> no problems and acceptable performance.
> 
> Also, I made the buffer creation and restoring functions available
> externally because these are expensive operations and in this way the
> cost can be shared between several calls of the flood-fill function.
> 
> I'm sorry I don't understand who is the author of the original version
> to give proper credit.
> 
> USE AS:
> 
>  (let ((flood-fill-buffer (flood-fill-make-buffer dc)))
>     (flood-fill dc x y color1 color2 flood-fill-buffer)
>    ;; more calls to flood-fill...
>     (flood-fill-flush-buffer dc flood-fill-buffer))
> 
> OR AS:
>     (flood-fill dc x y color1 color2)
> 
> If buffer sharing between calls is not needed.
> 
> Cheers
> P.
> 
> ================
> 
> (require "simple-queue.rkt")
> 
> ;;https://github.com/acmeism/RosettaCodeData/blob/master/Task/Bitmap-Flood-fill/Racket/bitmap-flood-fill.rkt
> 
> ;; flood-fill: bitmap<%> number number color color -> void
> ;; An example of flood filling a bitmap.
> ;;
> ;; We'll use a raw, byte-oriented interface here for demonstration
> ;; purposes.  Racket does provide get-pixel and set-pixel functions
> ;; which work on color% structures rather than bytes, but it's useful
> ;; to see that the byte approach works as well.
> 
> (define (flood-fill-make-buffer bm)
>   (define-values (width0 height0) (send bm get-size))
>   (define width (inexact->exact width0))
>   (define height (inexact->exact height0))
>   (define buffer (make-bytes (* width height 4)))
>   (send bm get-argb-pixels 0 0 width height buffer)
>   buffer)
> 
> (define (flood-fill-flush-buffer bm buffer)
>   (define-values (width0 height0) (send bm get-size))
>   (define width (inexact->exact width0))
>   (define height (inexact->exact height0))
>   (send bm set-argb-pixels 0 0 width height buffer))
> 
> (define (flood-fill bm start-x start-y target-color replacement-color
> (buffer #f))
>   (define buffer-supplied buffer)
> 
>   ;; The iter function from the original in GitHub - PB
>   ;; The main loop.
>   ;; http://en.wikipedia.org/wiki/Flood_fill
>   #| (define (iter x y)
>     (when (and (in-bounds? x y) (target-color-at? x y))
>       (replace-color-at! x y)
>       (iter (add1 x) y)
>       (iter (sub1 x) y)
>       (iter x (add1 y))
>       (iter x (sub1 y))))
>   |#
> 
>   (define (maybe-enqueue! q x y)
>     (when (and (in-bounds? x y) (target-color-at? x y))
>       (enqueue! q x)
>       (enqueue! q y)))
> 
>   (define (iter x y)
>     (define q (make-queue))
>     (maybe-enqueue! q x y)
>     (let loop ()
>       (unless (queue-empty? q)
>         (define x (dequeue! q))
>         (define y (dequeue! q))
>         (when (and (in-bounds? x y) (target-color-at? x y))
>           (replace-color-at! x y)
>           (maybe-enqueue! q (add1 x) y)
>           (maybe-enqueue! q (sub1 x) y)
>           (maybe-enqueue! q x (add1 y))
>           (maybe-enqueue! q x (sub1 y)))
>         (loop))))
> 
> 
>   ;; With auxillary definitions below:
>   ;(define width (send bm get-width))
>   ;(define height (send bm get-height))
>   (define-values (width0 height0) (send bm get-size))
>   (define width (inexact->exact width0))
>   (define height (inexact->exact height0))
> 
>   (unless buffer-supplied
>     (set! buffer (flood-fill-make-buffer bm)))
> 
>   (define-values (target-red target-green target-blue)
>     (values (send target-color red)
>             (send target-color green)
>             (send target-color blue)))
> 
>   (define-values (replacement-red replacement-green replacement-blue)
>     (values (send replacement-color red)
>             (send replacement-color green)
>             (send replacement-color blue)))
> 
>   (define (offset-at x y) (* 4 (+ (* y width) x)))
> 
>   (define (target-color-at? x y)
>     (define offset (offset-at x y))
>     (and (= (bytes-ref buffer (+ offset 1)) target-red)
>          (= (bytes-ref buffer (+ offset 2)) target-green)
>          (= (bytes-ref buffer (+ offset 3)) target-blue)))
> 
>   (define (replace-color-at! x y)
>     (define offset (offset-at x y))
>     (bytes-set! buffer (+ offset 1) replacement-red)
>     (bytes-set! buffer (+ offset 2) replacement-green)
>     (bytes-set! buffer (+ offset 3) replacement-blue))
> 
>   (define (in-bounds? x y)
>     (and (<= 0 x) (< x width) (<= 0 y) (< y height)))
> 
>   ;; Finally, let's do the fill, and then store the
>   ;; result back into the bitmap:
>   (iter start-x start-y)
> 
>   (unless buffer-supplied
>     (flood-fill-flush-buffer bm buffer)))
> 
> ============================================================
> simple-queues.rkt
> 
> #lang racket
> 
> (provide make-queue enqueue! dequeue! queue-empty? queue-length)
> 
> (struct queue
>   (store front rear)
>   #:mutable
>   #:transparent)
> 
> (define (make-queue (init-dim 10))
>   (queue (make-vector init-dim #f)
>          0
>          0))
> 
> (define (queue-empty? q)
>   (match q
>     ((queue _ front rear)
>      (= front rear))))
> 
> (define grow-factor 2)
> 
> (define (enqueue! q v)
>   (match q
>     ((queue store front rear)
>      (define len (vector-length store))
>      (let ((new-rear (modulo (add1 rear) len)))
>        (cond ((= new-rear front)
>               (let ((new-queue (make-queue (inexact->exact (round (*
> (vector-length store) grow-factor))))))
>                 (let loop ()
>                   (cond ((queue-empty? q)
>                          (match new-queue
>                            ((queue store front rear)
>                             (set-queue-store! q store)
>                             (set-queue-front! q front)
>                             (set-queue-rear! q rear)))
>                          (enqueue! q v))
>                         (else
>                          (enqueue! new-queue (dequeue! q))
>                          (loop))))))
>              (else
>               (vector-set! store new-rear v)
>               (set-queue-rear! q new-rear)))))))
> 
> (define (dequeue! q)
>   (match q
>     ((queue store front rear)
>      (let ((new-front (modulo (add1 front) (vector-length store))))
>        (set-queue-front! q new-front)
>        (vector-ref store new-front)))))
> 
> (define (queue-length q)
>   (match q
>     ((queue store front rear)
>      (if (<= front rear)
>        (- rear front)
>        (- (+ rear (vector-length store)) front)))))
> 
> == EOF ==
> 
> 
> 
> 
> On Sun, Oct 5, 2014 at 10:30 PM, Jens Axel Søgaard
> <jensaxel at soegaard.net> wrote:
> > Maybe this can be used?
> >
> > https://github.com/acmeism/RosettaCodeData/blob/master/Task/Bitmap-Flood-fill/Racket/bitmap-flood-fill.rkt
> >
> > /Jens Axel
> >
> >
> > 2014-10-05 22:14 GMT+02:00 Pierpaolo Bernardi <olopierpa at gmail.com>:
> >> Hello,
> >>
> >> here's a couple of dumb questions: I did not find a flood-fill method
> >> for bitmaps.  Am I right it's not there, or I missed it?
> >>
> >> I tried implementing one myself, but the result is way too slow to be
> >> useful. Any recommendation?
> >>
> >> Cheers
> >> P.
> >> ____________________
> >>   Racket Users list:
> >>   http://lists.racket-lang.org/users
> >
> >
> >
> > --
> > --
> > Jens Axel Søgaard
> 
> ____________________
>   Racket Users list:
>   http://lists.racket-lang.org/users