Guest User

Untitled

a guest
Jul 16th, 2018
71
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 2.18 KB | None | 0 0
  1. module Main where
  2. import Control.Arrow
  3. import Data.Array
  4. import Data.Char
  5. import Data.Bits
  6. import Data.Function
  7. import Data.List
  8. import Data.Maybe
  9.  
  10. type Bark = Array (Int, Int) Bool
  11.  
  12. main = do
  13. barks <- readBarks
  14. print $ map solve barks
  15.  
  16. readBarks :: IO [Bark]
  17. readBarks = do
  18. s <- getContents
  19. return (parseBarks s)
  20.  
  21. parseBarks :: String -> [Bark]
  22. parseBarks s =
  23. let _ : rest = lines s
  24. parse (mn:s) =
  25. let [m, n] = map read $ words mn
  26. (ls, rs) = splitAt m s
  27. parseBits = take n . concatMap toBits
  28. in (listArray ((0,0), (m-1, n-1)) (concatMap parseBits ls), rs)
  29. in chop parse rest
  30.  
  31. toBits c = [ testBit x i | i <- [3,2,1,0]]
  32. where x = digitToInt c
  33.  
  34. type BarkSize = Array (Int,Int) Int
  35.  
  36. printBarkSize x = putStrLn $ unlines $ map show $
  37. blockBy (snd (snd $ bounds x) + 1) $ elems x
  38.  
  39. barkSizes :: Bark -> BarkSize
  40. barkSizes bark = res
  41. where
  42. res = mapWithIndex f bark
  43. (ur,uc) = snd $ bounds bark
  44.  
  45. f (r,c) me | r == ur || c == uc = 1
  46. | not $ all (== me) check = 1
  47. | otherwise = minimum [down,right,downRight] + 1
  48. where
  49. check = [bark ! (r+1,c+1), not $ bark ! (r+1,c), not $ bark ! (r,c+1)]
  50. down = res ! (r+1,c)
  51. right = res ! (r,c+1)
  52. downRight = res ! (r+1,c+1)
  53.  
  54. cutBiggest :: BarkSize -> Maybe (Int, BarkSize)
  55. cutBiggest x | n == 0 = Nothing
  56. | otherwise = Just (n, cutBark p n x)
  57. where (p,n) = findBiggest x
  58.  
  59. findBiggest = maximumBy (compare `on` snd) . reverse . assocs
  60.  
  61. cutBark :: (Int,Int) -> Int -> BarkSize -> BarkSize
  62. cutBark (r,c) n = mapWithIndex f
  63. where f (r',c') x | inRange ((r,c),(r+n-1,c+n-1)) (r',c') = 0
  64. | otherwise = min dist x
  65. where dist = min (g $ r-r') (g $ c-c')
  66. g i = if i <= 0 then maxBound else i
  67.  
  68. mapWithIndex :: Ix i => (i -> a -> b) -> Array i a -> Array i b
  69. mapWithIndex f a = listArray (bounds a) . map (uncurry f) . assocs $ a
  70.  
  71. chop :: ([a] -> (b, [a])) -> [a] -> [b]
  72. chop _ [] = []
  73. chop f xs = y : chop f xs'
  74. where (y, xs') = f xs
  75.  
  76. blockBy :: Int -> [a] -> [[a]]
  77. blockBy n = chop (splitAt n)
  78.  
  79. solve = map (head &&& length) . group . unfoldr cutBiggest . barkSizes
Add Comment
Please, Sign In to add comment