day 15, common lib creation

14-a.hs

@@ -0,0 +1,67 @@
+import Prelude
+import Data.List.Split (splitOn)
+import qualified Data.Map.Lazy as M
+import Data.Map.Lazy ((!))
+
+data Tile = Wall | Sand
+  deriving (Eq)
+
+type Pos = (Int, Int)
+type Grid a = M.Map Pos a
+
+(!!!) :: Grid a -> Pos -> a
+(!!!) = (!)
+
+-- parsing time...
+
+writeWall :: Grid Tile -> [Pos] -> Grid Tile
+writeWall startGrid positions = snd $ foldl (\(oldPos, grid) newPos -> (newPos, writeWall' grid (oldPos, newPos))) (head positions, startGrid) positions
+  where
+    writeWall' :: Grid Tile -> (Pos, Pos) -> Grid Tile
+    writeWall' grid ((x1, y1), (x2, y2)) = grid `M.union` wallsGrid
+      where
+        wallsGrid = M.fromList $ concatMap (\y -> map (\x -> ((x, y), Wall)) [minX .. maxX]) [minY .. maxY]
+        minX = min x1 x2
+        minY = min y1 y2
+        maxX = max x1 x2
+        maxY = max y1 y2
+
+writeWalls :: [[Pos]] -> Grid Tile
+writeWalls = foldl writeWall M.empty
+
+parsePos :: String -> Pos
+parsePos p = (read $ split !! 0, read $ split !! 1)
+  where split = splitOn "," p
+
+parseWall :: String -> [Pos]
+parseWall = map parsePos . splitOn " -> "
+
+sandPos = (500, 0)
+
+dropSand :: Grid Tile -> Maybe (Grid Tile)
+dropSand grid = case sandGrain of
+  (Just pos) -> Just $ grid `M.union` M.singleton pos Sand
+  Nothing -> Nothing
+  where
+    sandGrain = resolveSand sandPos
+    maxY = maximum $ map snd $ M.keys grid
+
+    resolveSand :: Pos -> Maybe Pos
+    resolveSand (x, y)
+      | null validPositions = Just (x, y)
+      | y > maxY = Nothing
+      | otherwise = resolveSand $ head validPositions
+      where
+        validPositions = filter (not . (`M.member` grid)) [(x, y + 1), (x - 1, y + 1), (x + 1, y + 1)]
+
+repeatUntilNothing :: (a -> Maybe a) -> a -> a -> a
+repeatUntilNothing f previous input = case f input of
+  Just x -> repeatUntilNothing f input x
+  Nothing -> previous
+
+main = interact $
+  show
+  . (+ 1) . length . M.filter (== Sand)
+  . (\grid -> repeatUntilNothing dropSand grid grid)
+  . writeWalls
+  . map parseWall . lines

14-b.hs

@@ -0,0 +1,82 @@
+import Prelude
+import Data.List.Split (splitOn)
+import qualified Data.Map.Lazy as M
+import Data.Map.Lazy ((!))
+import GHC.IO (unsafePerformIO)
+import Control.DeepSeq (deepseq)
+
+data Tile = Wall | Sand
+  deriving (Eq)
+
+instance Show Tile where
+  show Wall = "#"
+  show Sand = "o"
+
+type Pos = (Int, Int)
+type Grid a = M.Map Pos a
+
+(!!!) :: Grid a -> Pos -> a
+(!!!) = (!)
+
+-- parsing time...
+
+writeWall :: Grid Tile -> [Pos] -> Grid Tile
+writeWall startGrid positions = snd $ foldl (\(oldPos, grid) newPos -> (newPos, writeWall' grid (oldPos, newPos))) (head positions, startGrid) positions
+  where
+    writeWall' :: Grid Tile -> (Pos, Pos) -> Grid Tile
+    writeWall' grid ((x1, y1), (x2, y2)) = grid `M.union` wallsGrid
+      where
+        wallsGrid = M.fromList $ concatMap (\y -> map (\x -> ((x, y), Wall)) [minX .. maxX]) [minY .. maxY]
+        minX = min x1 x2
+        minY = min y1 y2
+        maxX = max x1 x2
+        maxY = max y1 y2
+
+writeWalls :: [[Pos]] -> Grid Tile
+writeWalls = foldl writeWall M.empty
+
+parsePos :: String -> Pos
+parsePos p = (read $ split !! 0, read $ split !! 1)
+  where split = splitOn "," p
+
+parseWall :: String -> [Pos]
+parseWall = map parsePos . splitOn " -> "
+
+{-# NOINLINE debug #-}
+debug :: Show a => a -> ()
+debug = unsafePerformIO . print
+
+trace :: Show b => b -> a -> a
+trace s = deepseq (debug s)
+
+sandPos = (500, 0)
+
+dropSand :: Grid Tile -> Maybe (Grid Tile)
+dropSand grid = case sandGrain of
+  (Just pos) -> Just $ grid `M.union` M.singleton pos Sand
+  Nothing -> Nothing
+  where
+    sandGrain = resolveSand sandPos
+    groundY = maxY + 2
+    maxY = maximum $ map snd $ M.keys $ M.filter (== Wall) grid
+
+    resolveSand :: Pos -> Maybe Pos
+    resolveSand (x, y)
+      | y >= (groundY - 1) = Just (x, y)
+      | null validPositions && (x, y) == sandPos = Nothing
+      | null validPositions = Just (x, y)
+      | otherwise = resolveSand $ head validPositions
+      where
+        validPositions = filter (not . (`M.member` grid)) [(x, y + 1), (x - 1, y + 1), (x + 1, y + 1)]
+
+repeatUntilNothing :: (a -> Maybe a) -> a -> a -> a
+repeatUntilNothing f previous input = case f input of
+  Just x -> repeatUntilNothing f input x
+  Nothing -> previous
+
+main = interact $
+  show
+  . (+ 2) . length . M.filter (== Sand)
+  . (\grid -> repeatUntilNothing dropSand grid grid)
+  . writeWalls
+  . map parseWall . lines

15-a.hs

@@ -0,0 +1,51 @@
+{-# LANGUAGE TupleSections #-}
+import Common
+import Data.List.Split (splitOn)
+import Data.List (find)
+import Data.Char (isNumber)
+import Data.Maybe (isJust)
+
+type SensorData = (Pos, Int)
+
+parseLine :: String -> SensorData
+parseLine l = (sensorPos, sensorPos `taxicabDist` beaconPos)
+  where
+    sensorPos = getPos left
+    beaconPos = getPos right
+
+    getPos :: String -> Pos
+    getPos s = (x, y)
+      where [x, y] = map (read . filter isNumber) $ filter (isJust . find isNumber) $ words s
+
+    [left, right] = splitOn ":" l
+
+scanY :: Int
+scanY = 2000000
+
+getMinX :: SensorData -> Int
+getMinX ((x, y), dist) = x - dist
+getMaxX :: SensorData -> Int
+getMaxX ((x, y), dist) = x + dist
+
+getXScanRange :: [SensorData] -> (Int, Int)
+getXScanRange sensors = (minX, maxX)
+  where
+    minX = minimum $ map getMinX sensors
+    maxX = maximum $ map getMaxX sensors
+
+-- manual recursion for extra speed
+canContainBeacon :: [SensorData] -> Pos -> Bool
+canContainBeacon ((sensorPos, sensorRange):xs) p = p `taxicabDist` sensorPos > sensorRange && (canContainBeacon xs p)
+canContainBeacon [] _ = True
+
+countContainsBeacon :: [SensorData] -> Int
+countContainsBeacon sensors = count (not . canContainBeacon sensors) $ map (, scanY) [minX .. maxX]
+  where
+    (minX, maxX) = getXScanRange sensors
+
+main = interact $
+  show
+  . flip (-) 1
+  . countContainsBeacon
+  . map parseLine
+  . lines

15-b.hs

@@ -0,0 +1,63 @@
+{-# OPTIONS_GHC -O2 #-}
+{-# LANGUAGE TupleSections #-}
+import Common
+import Data.List.Split (splitOn)
+import Data.List (find)
+import Data.Char (isNumber)
+import Data.Maybe (fromJust, isJust)
+
+type SensorData = (Pos, Int)
+
+parseLine :: String -> SensorData
+parseLine l = (sensorPos, sensorPos `taxicabDist` beaconPos)
+  where
+    sensorPos = getPos left
+    beaconPos = getPos right
+
+    getPos :: String -> Pos
+    getPos s = (x, y)
+      where [x, y] = map (read . filter isNumber) $ filter (isJust . find isNumber) $ words s
+
+    [left, right] = splitOn ":" l
+
+beaconMaxX :: Int
+beaconMaxX = 4000000
+beaconMaxY :: Int
+beaconMaxY = 4000000
+
+-- manual recursion for extra speed
+canContainBeacon :: [SensorData] -> Pos -> Bool
+canContainBeacon ((sensorPos, sensorRange):xs) p = p `taxicabDist` sensorPos > sensorRange && (canContainBeacon xs p)
+canContainBeacon [] _ = True
+
+dedup a b
+  | a == b = [a]
+  | otherwise = [a, b]
+
+possibleSpots :: SensorData -> [Pos]
+possibleSpots ((x, y), dist) = concatMap drawLine [y - dist - 1 .. y + dist + 1]
+  where
+    drawLine y' = map (, y') (dedup (x - (dist - yDist) - 1) (x + (dist - yDist) + 1))
+      where
+        yDist = abs $ y' - y
+
+findBeaconInPositions :: [SensorData] -> [Pos] -> Maybe Pos
+findBeaconInPositions sensors = find canContainBeacon'
+  where
+    -- does this help performance???
+    canContainBeacon' = canContainBeacon sensors
+
+findBeacon :: [SensorData] -> Pos
+findBeacon sensors = fromJust $ findBeaconInPositions sensors positions
+  where
+    positions = filter (\(x, y) -> x >= 0 && x <= beaconMaxX && y >= 0 && y <= beaconMaxY) $ concatMap possibleSpots sensors
+
+getTuningFrequency :: Pos -> Int
+getTuningFrequency (x, y) = x * 4000000 + y
+
+main = interact $
+  show
+  . getTuningFrequency
+  . findBeacon
+  . map parseLine
+  . lines

Common.hs

@@ -0,0 +1,45 @@
+-- commonly used functions, types and etc
+
+module Common where
+import Data.List (findIndex, elemIndex)
+import GHC.IO (unsafePerformIO)
+import Control.DeepSeq (deepseq)
+
+type Pos = (Int, Int)
+type Grid a = [[a]]
+
+(!!!) :: Grid a -> Pos -> a
+(!!!) grid (x, y) = grid !! y !! x
+
+findPos :: (Eq a) => a -> Grid a -> Maybe Pos
+findPos target grid = do
+  y <- findIndex (target `elem`) grid
+  x <- elemIndex target (grid !! y)
+  Just (x, y)
+
+gridMap :: (a -> b) -> Grid a -> Grid b
+gridMap f = map (map f)
+
+gridWidth :: Grid a -> Int
+gridWidth = length . head
+gridHeight :: Grid a -> Int
+gridHeight = length
+
+taxicabDist :: Pos -> Pos -> Int
+taxicabDist (x1, y1) (x2, y2) = abs (x1 - x2) + abs (y1 - y2)
+
+addPos :: Pos -> Pos -> Pos
+addPos (x1, y1) (x2, y2) = (x1 + x2, y1 + y2)
+
+subPos :: Pos -> Pos -> Pos
+subPos (x1, y1) (x2, y2) = (x1 - x2, y1 - y2)
+
+{-# NOINLINE debug #-}
+debug :: Show a => a -> ()
+debug = unsafePerformIO . print
+
+trace :: Show b => b -> a -> a
+trace s = deepseq (debug s)
+
+count :: (a -> Bool) -> [a] -> Int
+count f = length . filter f