Data commit

Task/Bitmap-Flood-fill/Haskell/bitmap-flood-fill.hs

@@ -0,0 +1,110 @@
+import Data.Array.ST
+import Data.STRef
+import Control.Monad
+import Control.Monad.ST
+import Bitmap
+
+-- Implementation of a stack in the ST monad
+pushST :: STStack s a -> a -> ST s ()
+pushST s e = do
+    s2 <- readSTRef s
+    writeSTRef s (e : s2)
+
+popST :: STStack s a -> ST s (Stack a)
+popST s = do
+    s2 <- readSTRef s
+    writeSTRef s $ tail s2
+    return $ take 1 s2
+
+isNotEmptySTStack :: STStack s a -> ST s Bool
+isNotEmptySTStack s = do
+    s2 <- readSTRef s
+    return $ not $ null s2
+
+emptySTStack :: ST s (STStack s a)
+emptySTStack = newSTRef []
+
+consumeSTStack :: STStack s a -> (a -> ST s ()) -> ST s ()
+consumeSTStack s f = do
+    check <- isNotEmptySTStack s
+    when check $ do
+        e <- popST s
+        f $ head e
+        consumeSTStack s f
+
+type Spanning s = STRef s (Bool, Bool)
+
+setSpanLeft :: Spanning s -> Bool -> ST s ()
+setSpanLeft s v = do
+    (_, r) <- readSTRef s
+    writeSTRef s (v, r)
+
+setSpanRight :: Spanning s -> Bool -> ST s ()
+setSpanRight s v = do
+    (l, _) <- readSTRef s
+    writeSTRef s (l, v)
+
+setSpanNone :: Spanning s -> ST s ()
+setSpanNone s = writeSTRef s (False, False)
+
+floodFillScanlineStack :: Color c => Image s c -> Pixel -> c -> ST s (Image s c)
+floodFillScanlineStack b coords newC = do
+    stack <- emptySTStack -- new empty stack holding pixels to fill
+    spans <- newSTRef (False, False) -- keep track of spans in scanWhileX
+    fFSS b stack coords newC spans -- function loop
+    return b
+    where
+        fFSS b st c newC p = do
+            oldC <- getPix b c
+            unless (oldC == newC) $ do
+                pushST st c -- store the coordinates in the stack
+                (w, h) <- dimensions b
+                consumeSTStack st (scanWhileY b p oldC >=>
+                    scanWhileX b st p oldC newC (w, h))
+
+        -- take a buffer, the span record, the color of the Color the fill is
+        -- started from, a coordinate from the stack, and returns the coord
+        -- of the next point to be filled in the same column
+        scanWhileY b p oldC coords@(Pixel (x, y)) =
+            if y >= 0
+            then do
+                z <- getPix b coords
+                if z == oldC
+                then scanWhileY b p oldC (Pixel (x, y - 1))
+                else do
+                    setSpanNone p
+                    return (Pixel (x, y + 1))
+            else do
+                setSpanNone p
+                return (Pixel (x, y + 1))
+
+        -- take a buffer, a stack, a span record, the old and new color, the
+        -- height and width of the buffer, and a coordinate.
+        -- paint the point with the new color, check if the fill must expand
+        -- to the left or right or both, and store those coordinates in the
+        -- stack for subsequent filling
+        scanWhileX b st p oldC newC (w, h) coords@(Pixel (x, y)) =
+            when (y < h) $ do
+                z <- getPix b coords
+                when (z == oldC) $ do
+                    setPix b coords newC
+                    (spanLeft, spanRight) <- readSTRef p
+                    when (not spanLeft && x > 0) $ do
+                        z2 <- getPix b (Pixel (x - 1, y))
+                        when (z2 == oldC) $ do
+                            pushST st (Pixel (x - 1, y))
+                            setSpanLeft p True
+                    when (spanLeft && x > 0) $ do
+                        z3 <- getPix b (Pixel (x - 1, y))
+                        when (z3 /= oldC) $
+                            setSpanLeft p False
+                    when (not spanRight && x < (w - 1)) $ do
+                        z4 <- getPix b (Pixel (x + 1, y))
+                        when (z4 == oldC) $ do
+                            pushST st (Pixel (x + 1, y))
+                            setSpanRight p True
+                    when (spanRight && x < (w - 1)) $ do
+                        z5 <- getPix b (Pixel (x + 1, y))
+                        when (z5 /= oldC) $
+                            setSpanRight p False
+                    scanWhileX b st p oldC newC (w, h) (Pixel (x, y + 1))