12-1

1 files changed, 72 insertions, 0 deletions

diff --git a/12-1.hs b/12-1.hs
new file mode 100644
index 0000000..78ea186
--- /dev/null
+++ b/12-1.hs
@@ -0,0 +1,72 @@
+import Data.Array
+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 [p] [p]
+  where
+    go :: [(Int,Int)]  -> [(Int,Int)] -> [(Int,Int)]
+    go visited points =
+      let v = filter f
+            . filter (not . (`elem` visited))
+            . nub
+            . concatMap neighbours
+            $ points
+      in case v of
+           [] -> visited
+           _  -> go (visited ++ 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