122 lines
4.2 KiB
Haskell
122 lines
4.2 KiB
Haskell
import Data.Array
|
|
import qualified Data.List as List
|
|
|
|
data BW = Black | White
|
|
deriving (Eq, Show)
|
|
|
|
type Index = (Int, Int)
|
|
type BWArray = Array Index BW
|
|
|
|
toBW :: Char -> BW
|
|
toBW '0' = White
|
|
toBW '1' = Black
|
|
toBW ' ' = White
|
|
toBW '#' = Black
|
|
toBW _ = error "toBW: illegal char"
|
|
|
|
toBWArray :: [String] -> BWArray
|
|
toBWArray strings = arr
|
|
where
|
|
height = length strings
|
|
width = minimum $ map length strings
|
|
arr = listArray ((0, 0), (width - 1, height - 1))
|
|
. map toBW . concat . List.transpose $ map (take width) strings
|
|
|
|
toChar :: BW -> Char
|
|
toChar White = ' '
|
|
toChar Black = '#'
|
|
|
|
chunksOf :: Int -> [a] -> [[a]]
|
|
chunksOf _ [] = []
|
|
chunksOf n xs = take n xs : (chunksOf n $ drop n xs)
|
|
|
|
showBWArray :: BWArray -> String
|
|
showBWArray arr =
|
|
List.intercalate "\n" . List.transpose
|
|
. chunksOf (height + 1) . map toChar $ elems arr
|
|
where
|
|
(_, (_, height)) = bounds arr
|
|
|
|
add :: Num a => (a, a) -> (a, a) -> (a, a)
|
|
add (a, b) (x, y) = (a + x, b + y)
|
|
|
|
within :: Ord a => ((a, a), (a, a)) -> (a, a) -> Bool
|
|
within ((a, b), (c, d)) (x, y) =
|
|
a <= x && x <= c &&
|
|
b <= y && y <= d
|
|
|
|
p2, p3, p4, p5, p6, p7, p8, p9 :: Index
|
|
p2 = ( 0, -1)
|
|
p3 = ( 1, -1)
|
|
p4 = ( 1, 0)
|
|
p5 = ( 1, 1)
|
|
p6 = ( 0, 1)
|
|
p7 = (-1, 1)
|
|
p8 = (-1, 0)
|
|
p9 = (-1, -1)
|
|
|
|
ixamap :: Ix i => ((i, a) -> b) -> Array i a -> Array i b
|
|
ixamap f a = listArray (bounds a) $ map f $ assocs a
|
|
|
|
thin :: BWArray -> BWArray
|
|
thin arr =
|
|
if pass2 == arr then pass2 else thin pass2
|
|
where
|
|
(low, high) = bounds arr
|
|
lowB = low `add` (1, 1)
|
|
highB = high `add` (-1, -1)
|
|
isInner = within (lowB, highB)
|
|
offs p = map (add p) [p2, p3, p4, p5, p6, p7, p8, p9]
|
|
trans c (a, b) = if a == White && b == Black then c + 1 else c
|
|
zipshift xs = zip xs (drop 1 xs ++ xs)
|
|
transitions a = (== (1 :: Int)) . foldl trans 0 . zipshift . map (a !) . offs
|
|
within2to6 n = 2 <= n && n <= 6
|
|
blacks a p = within2to6 . length . filter ((== Black) . (a !)) $ offs p
|
|
oneWhite xs a p = any ((== White) . (a !) . add p) xs
|
|
oneRight = oneWhite [p2, p4, p6]
|
|
oneDown = oneWhite [p4, p6, p8]
|
|
oneUp = oneWhite [p2, p4, p8]
|
|
oneLeft = oneWhite [p2, p6, p8]
|
|
precond a p = (a ! p == Black) && isInner p && blacks a p && transitions a p
|
|
stage1 a p = precond a p && oneRight a p && oneDown a p
|
|
stage2 a p = precond a p && oneUp a p && oneLeft a p
|
|
stager f (p, d) = if f p then White else d
|
|
pass1 = ixamap (stager $ stage1 arr) arr
|
|
pass2 = ixamap (stager $ stage2 pass1) pass1
|
|
|
|
sampleExA :: [String]
|
|
sampleExA =
|
|
["00000000000000000000000000000000"
|
|
,"01111111110000000111111110000000"
|
|
,"01110001111000001111001111000000"
|
|
,"01110000111000001110000111000000"
|
|
,"01110001111000001110000000000000"
|
|
,"01111111110000001110000000000000"
|
|
,"01110111100000001110000111000000"
|
|
,"01110011110011101111001111011100"
|
|
,"01110001111011100111111110011100"
|
|
,"00000000000000000000000000000000"]
|
|
|
|
sampleExB :: [String]
|
|
sampleExB =
|
|
[" "
|
|
," ################# ############# "
|
|
," ################## ################ "
|
|
," ################### ################## "
|
|
," ######## ####### ################### "
|
|
," ###### ####### ####### ###### "
|
|
," ###### ####### ####### "
|
|
," ################# ####### "
|
|
," ################ ####### "
|
|
," ################# ####### "
|
|
," ###### ####### ####### "
|
|
," ###### ####### ####### "
|
|
," ###### ####### ####### ###### "
|
|
," ######## ####### ################### "
|
|
," ######## ####### ###### ################## ###### "
|
|
," ######## ####### ###### ################ ###### "
|
|
," ######## ####### ###### ############# ###### "
|
|
," "]
|
|
|
|
main :: IO ()
|
|
main = mapM_ (putStrLn . showBWArray . thin . toBWArray) [sampleExA, sampleExB]
|