[racket] flood-fill?

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