Chess boards

gistfile1.hs

module Main where
import Control.Arrow
import Data.Array
import Data.Char
import Data.Bits
import Data.Function
import Data.List
import Data.Maybe

type Bark = Array (Int, Int) Bool

main = do
    barks <- readBarks
    print $ map solve barks

readBarks :: IO [Bark]
readBarks = do
    s <- getContents
    return (parseBarks s)
    
parseBarks :: String -> [Bark]
parseBarks s =
    let _ : rest = lines s
        parse (mn:s) =
            let [m, n] = map read $ words mn
                (ls, rs) = splitAt m s
                parseBits = take n . concatMap toBits
            in  (listArray ((0,0), (m-1, n-1)) (concatMap parseBits ls), rs)
    in  chop parse rest

toBits c = [ testBit x i | i <- [3,2,1,0]]
  where x = digitToInt c

type BarkSize = Array (Int,Int) Int

printBarkSize x = putStrLn $ unlines $ map show $
  blockBy (snd (snd $ bounds x) + 1) $ elems x

barkSizes :: Bark -> BarkSize
barkSizes bark = res
  where
    res = mapWithIndex f bark
    (ur,uc) = snd $ bounds bark
  
    f (r,c) me | r == ur || c == uc = 1
               | not $ all (== me) check = 1
               | otherwise = minimum [down,right,downRight] + 1
      where
        check = [bark ! (r+1,c+1), not $ bark ! (r+1,c), not $ bark ! (r,c+1)]
        down = res ! (r+1,c)
        right = res ! (r,c+1)
        downRight = res ! (r+1,c+1)

cutBiggest :: BarkSize -> Maybe (Int, BarkSize)
cutBiggest x | n == 0 = Nothing
             | otherwise = Just (n, cutBark p n x)
  where (p,n) = findBiggest x

findBiggest = maximumBy (compare `on` snd) . reverse . assocs

cutBark :: (Int,Int) -> Int -> BarkSize -> BarkSize
cutBark (r,c) n = mapWithIndex f
  where f (r',c') x | inRange ((r,c),(r+n-1,c+n-1)) (r',c') = 0
                    | otherwise = min dist x
             where dist = min (g $ r-r') (g $ c-c')
                   g i = if i <= 0 then maxBound else i

mapWithIndex :: Ix i => (i -> a -> b) -> Array i a -> Array i b
mapWithIndex f a = listArray (bounds a) . map (uncurry f) . assocs $ a

chop :: ([a] -> (b, [a])) -> [a] -> [b]
chop _ [] = []
chop f xs = y : chop f xs'
  where (y, xs') = f xs

blockBy :: Int -> [a] -> [[a]]
blockBy n = chop (splitAt n)

solve = map (head &&& length) . group . unfoldr cutBiggest . barkSizes