src/advent06/advent06.hs

   1     {-# LANGUAGE OverloadedStrings #-}
   2
   3     import Data.List
   4
   5     import Data.Text (Text)
   6     import qualified Data.Text.IO as TIO
   7
   8     import Data.Void (Void)
   9
  10     import Text.Megaparsec
  11     import Text.Megaparsec.Char
  12     import qualified Text.Megaparsec.Char.Lexer as L
  13     import qualified Control.Applicative as CA
  14
  15     import qualified Data.Map.Strict as M
  16
  17     type Coord = (Integer, Integer) -- x, y
  18     type Bounds = (Integer, Integer, Integer, Integer) -- minX, maxX, minY, maxY
  19     type Region = M.Map Coord Int
  20
  21     main :: IO ()
  22     main = do
  23             text <- TIO.readFile "data/advent06.txt"
  24             let coords = successfulParse text
  25             let boundingBox = findBounds coords
  26             print $ length coords
  27             print boundingBox
  28             print $ part1 coords boundingBox
  29             print $ part2 coords boundingBox
  30
  31
  32     part1 coords bounds = largestRegion $ regionSizes $ finite edgeLabels regions
  33         where regions = findRegions coords bounds
  34               edgeLabels = infinite regions bounds
  35
  36     part2 coords bounds = M.size $ M.filter (< 10000) $ safeCells coords bounds
  37
  38     findRegions :: [Coord] -> Bounds -> Region
  39     findRegions coords (minX, maxX, minY, maxY) = M.fromList labelledCells
  40         where cells = [(x, y) | x <- [minX .. maxX], y <- [minY .. maxY] ]
  41               starts = zip [1..] coords
  42               labelledCells = map (\c -> (c, nearestStart 0 c starts)) cells
  43
  44     nearestStart :: Int -> Coord -> [(Int, Coord)] -> Int
  45     nearestStart tieLabel cell starts = nearestLabel
  46         where distances = sort $ map (\(l, s) -> (distance s cell , l)) starts
  47               nearestLabel = if fst (distances!!0) == fst (distances!!1)
  48                              then tieLabel
  49                              else snd (distances!!0)
  50
  51
  52     safeCells :: [Coord] -> Bounds -> Region
  53     safeCells coords (minX, maxX, minY, maxY) = M.fromList distanceCells
  54         where cells = [(x, y) | x <- [minX .. maxX], y <- [minY .. maxY] ]
  55               distanceCells = map (\c -> (c, fromIntegral $ sumDistance c coords) ) cells
  56
  57
  58     sumDistance :: Coord -> [Coord] -> Integer
  59     sumDistance here others = sum $ map (\c -> distance here c) others
  60
  61
  62     infinite :: Region -> Bounds -> [Int]
  63     infinite regions (minX, maxX, minY, maxY) = nub $ sort $ M.elems $ M.filterWithKey onEdge regions
  64         where onEdge (x, y) _ = (x == minX) || (x == maxX) || (y == minY) || (y == maxY)
  65
  66     finite :: [Int] -> Region -> Region
  67     finite excluded regions = M.filter (\r -> r `notElem` excludedTied) regions
  68         where excludedTied = (0:excluded)
  69
  70
  71     regionSizes :: Region -> [(Int, Int)]
  72     regionSizes regions = map (\g -> (g!!0, length g)) $ group $ sort $ M.elems regions
  73
  74
  75     largestRegion :: [(Int, Int)] -> Int
  76     largestRegion = maximum . map snd
  77
  78
  79     findBounds :: [Coord] -> (Integer, Integer, Integer, Integer)
  80     findBounds coords = ( minX - (maxY - minY) `div` 2 -- small x edge
  81                         , maxX + (maxY - minY) `div` 2 -- large x edge
  82                         , minY - (maxX - minX) `div` 2-- small x edge
  83                         , maxY + (maxX - minX) `div` 2 -- large y edge
  84                         )
  85         where maxX = maximum $ map fst coords
  86               minX = minimum $ map fst coords
  87               maxY = maximum $ map snd coords
  88               minY = minimum $ map snd coords
  89
  90     -- Manhattan distance
  91     distance :: Coord -> Coord -> Integer
  92     distance (x1, y1) (x2, y2) = (abs (x1 - x2)) + (abs (y1 - y2))
  93
  94
  95     -- Parse the input file
  96
  97     type Parser = Parsec Void Text
  98
  99     sc :: Parser ()
 100     sc = L.space (skipSome spaceChar) CA.empty CA.empty
 101     -- sc = L.space (skipSome (char ' ')) CA.empty CA.empty
 102
 103     lexeme  = L.lexeme sc
 104     integer = lexeme L.decimal
 105     symb = L.symbol sc
 106
 107     commaP = symb ","
 108
 109
 110     coordFileP = many coordP
 111     coordP = (,) <$> integer <* commaP <*> integer
 112
 113     successfulParse :: Text -> [Coord]
 114     successfulParse input =
 115             case parse coordFileP "input" input of
 116                     Left  _error -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err
 117                     Right coords -> coords