Skip to content

Instantly share code, notes, and snippets.

@petermarks
Created December 10, 2010 18:57
Show Gist options
  • Save petermarks/736615 to your computer and use it in GitHub Desktop.
Save petermarks/736615 to your computer and use it in GitHub Desktop.
Chess boards
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment