I cleaned up my flood fill code and created a little demo app for it.
I have 3 different flood fill functions:
FLOOD-FILL-RECURSIVE - This function should not be used but it is
interesting to look at how simple a recursive flood fill can be.
FLOOD-FILL-STACK - A stack based flood fill that does a lot of consing
because it uses PUSH/POP as the stack. This function is fast and
probably the one to include in the SDL-GFX library.
FLOOD-FILL-CUSTOM-STACK - This function is the same as the one above
but has its own custom array-based stack. It was more of an
experiment to see if an array would be faster than a bunch of consing.
The timing of both functions indicates they run at the same speed.
With compiler declarations it may have better results. Another
disadvantage to this is it preallocates the stack, chewing up quite a
bit of ram.
I didn't come up with these functions on my own. I converted the C
code on this page:
http://student.kuleuven.be/~m0216922/CG/floodfill.html
Comments are welcome.
Anthony
(eval-when (:compile-toplevel :load-toplevel :execute)
(asdf:operate 'asdf:load-op :lispbuilder-sdl))
(in-package #:lispbuilder-sdl)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; A naive recursive flood fill algorithm
;;
;; This function will most certainly blow the stack.
;;
(defun flood-fill-recursive (surface x y new-color)
(sdl-base::with-pixel (pixels (fp surface))
(let ((width (width surface))
(height (height surface))
(replacement-color (sdl:map-color new-color surface))
(target-color (sdl-base::read-pixel pixels x y)))
(assert (/= target-color replacement-color))
(labels ((fill (x y)
(when (and (>= x 0)(>= y 0)(< x width)(< y height)
(/= target-color
(sdl-base::read-pixel pixels x y)))
(return-from fill))
(sdl-base::write-pixel pixels x y replacement-color)
(fill (1- x) y)
(fill (1+ x) y)
(fill x (1+ y))
(fill x (1- y))))
(fill x y)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; A consy, scanline, stack based flood fill
;;
;; Code stolen from:
;; http://student.kuleuven.be/~m0216922/CG/floodfill.html
(defun flood-fill-stack (surface x y color)
(sdl-base::with-pixel (pixels (fp surface))
(let* ((stack nil)
(w (width surface))
(h (height surface))
(new-color (sdl:map-color color surface))
(old-color (sdl-base::read-pixel pixels x y)))
(when (/= old-color new-color)
(let ((y1)
(span-left)
(span-right))
(push x stack)(push y stack)
(loop
:while stack
:do (let ((y (pop stack))
(x (pop stack)))
(setf y1 y)
(loop
:while (and (>= y1 0) (= (sdl-base::read-pixel pixels x
y1)
old-color))
:do (decf y1))
(incf y1)
(setf span-left nil)
(setf span-right nil)
(loop
:while (and (< y1 h) (= (sdl-base::read-pixel pixels x y1)
old-color))
:do (progn (sdl-base::write-pixel pixels x y1 new-color)
(if (and (not span-left)
(> x 0)
(= (sdl-base::read-pixel pixels (- x
1) y1)
old-color))
(progn (push (- x 1) stack)
(push y1 stack)
(setf span-left T))
(if (and span-left
(> x 0)
(/= (sdl-base::read-pixel pixels
(- x 1) y1)
old-color))
(setf span-left nil)))
(if (and (not span-right)
(< x (1- w))
(= (sdl-base::read-pixel pixels (+ x
1) y1)
old-color))
(progn (push (+ x 1) stack)
(push y1 stack)
(setf span-right T))
(when (and span-right
(< x (1- w))
(/= (sdl-base::read-pixel
pixels (+ x 1) y1)
old-color))
(setf span-right nil)))
(incf y1))))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; A cons-less, scanline, stack based flood fill
;;
;; This algorithm implements its own stack for reducing
;; consing and better efficiency.
;;
;; Code stolen from:
;; http://student.kuleuven.be/~m0216922/CG/floodfill.html
(defparameter *ff-stack-size* 16777215)
;; This variable is used for efficient storage of (x,y) coordinates in
;; the stack. See FF-PUSH and FF-POP code.
(defparameter *ff-max-height* 1600)
;; We don't preallocate the stack because it increases the size of the
;; initial Lisp image
(defparameter *ff-stack* nil)
(defparameter *ff-stack-pointer* -1)
(defun ff-empty-stack()
"Intializes the stack. Allocates it if necessary."
(unless *ff-stack*
(setf *ff-stack* (make-array *ff-stack-size* :element-type 'fixnum)))
(setf *ff-stack-pointer* -1))
(defun ff-empty-p()
"Is the stack empty?"
(< *ff-stack-pointer* 0))
(defun ff-push(x y)
(declare (type fixnum x y)
(optimize (speed 3)(safety 0)))
(when (< (1- *ff-stack-pointer*))
(incf *ff-stack-pointer*)
(setf (aref *ff-stack* *ff-stack-pointer*)
(+ (* x *ff-max-height*) y))))
(defun ff-pop()
(when (>= *ff-stack-pointer* 0)
(let ((x (truncate (/ (aref *ff-stack* *ff-stack-pointer*)
*ff-max-height*)))
(y (mod (aref *ff-stack* *ff-stack-pointer*) *ff-max-height*)))
(decf *ff-stack-pointer*)
(values x y))))
(defun flood-fill-custom-stack (surface x y color)
(sdl-base::with-pixel (pixels (fp surface))
(let* ((w (width surface))
(h (height surface))
(new-color (sdl:map-color color surface))
(old-color (sdl-base::read-pixel pixels x y)))
(when (/= old-color new-color)
(ff-empty-stack)
(let ((y1)
(span-left)
(span-right))
(when (not (ff-push x y)) (return-from flood-fill-custom-stack nil))
(loop
:while (not (ff-empty-p))
:do (multiple-value-bind (x y)(ff-pop)
(setf y1 y)
(loop
:while (and (>= y1 0) (= (sdl-base::read-pixel pixels x
y1)
old-color))
:do (decf y1))
(incf y1)
(setf span-left nil)
(setf span-right nil)
(loop
:while (and (< y1 h) (= (sdl-base::read-pixel pixels x y1)
old-color))
:do (progn (sdl-base::write-pixel pixels x y1 new-color)
(if (and (not span-left)
(> x 0)
(= (sdl-base::read-pixel pixels (- x
1) y1)
old-color))
(progn (when (not (ff-push (- x 1) y1))
(return-from
flood-fill-custom-stack nil))
(setf span-left T))
(if (and span-left
(> x 0)
(/= (sdl-base::read-pixel pixels
(- x 1) y1)
old-color))
(setf span-left nil)))
(if (and (not span-right)
(< x (1- w))
(= (sdl-base::read-pixel pixels (+ x
1) y1)
old-color))
(progn (when (not (ff-push (+ x 1) y1))
(return-from
flood-fill-custom-stack nil))
(setf span-right T))
(when (and span-right
(< x (1- w))
(/= (sdl-base::read-pixel
pixels (+ x 1) y1)
old-color))
(setf span-right nil)))
(incf y1))))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Test Code
;;
;;
(defun test-flood-fill()
(let ((width 200) (height 200))
(sdl:with-init ()
(sdl::window width height :title-caption "Flood Fill")
(setf (sdl-base::frame-rate) 5)
(sdl::clear-display (sdl::color :r 0 :g 0 :b 0))
(sdl::with-color (black (sdl::color :r 255 :g 255 :b 255))
(sdl:draw-rectangle (sdl:rectangle :x 10 :y 10 :w 100 :h 100)
:surface *default-display* :color black)
(let ((iterations 10))
;; Time flood-fill-custom-stack
(time (loop
:for x :from 1 :to iterations
:do (sdl::with-color (random-color (sdl:color :r (random
256) :g (random 256) :b (random 256)))
(flood-fill-custom-stack *default-display* 20 20
random-color))))
;; Time flood-fill-stack
(time (loop
:for x :from 1 :to iterations
:do (sdl::with-color (random-color (sdl:color :r (random
256) :g (random 256) :b (random 256)))
(flood-fill-stack *default-display* 20 20
random-color))))))
(sdl:with-events ()
(:quit-event () t)
(:video-expose-event () (sdl::update-display))))))_______________________________________________
application-builder mailing list
[email protected]
http://www.lispniks.com/mailman/listinfo/application-builder
