111 lines
3.9 KiB
Haskell
111 lines
3.9 KiB
Haskell
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))
|