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]