1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
|
import Data.Array
import Data.HashSet as HS (HashSet, fromList, member, singleton, toList)
import Data.List (nub)
type Map = Array (Int,Int) (Maybe Char)
parse :: String -> Map
parse s = let ls = lines s
w = length $ head ls
h = length ls
in array ((0,0), (w-1,h-1)) [ ((x,y),Just $ ls !! y !! x)
| x <- [0..w-1]
, y <- [0..h-1]
]
findNext :: (Int,Int) -> Map -> Maybe (Int,Int)
findNext = go
where
go :: (Int,Int) -> Map -> Maybe (Int,Int)
go p@(x,y) m | inRange (bounds m) p = case m ! p of
Just _ -> Just p
Nothing -> let p' = (x+1,y)
in if inRange (bounds m) p'
then go p' m
else go (0,y+1) m
| otherwise = Nothing
getRegion :: Map -> (Int,Int) -> [(Int,Int)]
getRegion m p = go (HS.singleton p) [p]
where
go :: HS.HashSet (Int,Int) -> [(Int,Int)] -> [(Int,Int)]
go visited points =
let v = filter f
. filter (not . (`HS.member` visited))
. nub
. concatMap neighbours
$ points
in case v of
[] -> HS.toList visited
_ -> go (visited <> HS.fromList v) v
f :: (Int,Int) -> Bool
f p' = inRange (bounds m) p' && m ! p == m ! p'
markDone :: Map -> [(Int,Int)] -> Map
markDone m ps = m // map (,Nothing) ps
getRegions :: Map -> [[(Int,Int)]]
getRegions = go [] (0,0)
where
go :: [[(Int,Int)]] -> (Int,Int) -> Map -> [[(Int,Int)]]
go xs cur m = case findNext cur m of
Nothing -> xs
Just p -> let r = getRegion m p
in go (r : xs) p (markDone m r)
neighbours :: (Int,Int) -> [(Int,Int)]
neighbours (x,y) = [(x+1,y), (x-1,y), (x,y+1), (x,y-1)]
perimeter :: Map -> (Int,Int) -> Int
perimeter m p = length . filter f $ neighbours p
where
f :: (Int,Int) -> Bool
f p' = not (inRange (bounds m) p') || m ! p' /= m ! p
score :: Map -> [(Int,Int)] -> Int
score m r = length r * sum (map (perimeter m) r)
mapScore :: Map -> Int
mapScore m = sum . map (score m) . getRegions $ m
main :: IO ()
main = getContents >>= print . mapScore . parse
|
