Done day 15

diff --git a/advent15/Main.hs b/advent15/Main.hs
new file mode 100644 (file)
index 0000000..67dcadc
--- /dev/null
+++ b/advent15/Main.hs
@@ -0,0 +1,167 @@
+-- Writeup at https://work.njae.me.uk/2024/12/12/advent-of-code-2024-day-12/
+
+import AoC
+import Linear
+-- import qualified Data.Set as S
+import qualified Data.Set as S
+import Data.List (foldl', nub)
+import Data.Maybe
+
+type Position = V2 Int -- r, c
+type Items = S.Set Position
+data World = World { walls :: Items, boxes :: Items, robot :: Position }
+  deriving (Show, Eq, Ord)
+type Move = (Position, Position) -- move a box from here to there
+
+
+pattern U, D, L, R :: Position
+pattern U = V2 (-1) 0
+pattern D = V2 1 0
+pattern L = V2 0 (-1)
+pattern R = V2 0 1
+
+
+
+main :: IO ()
+main = 
+  do  dataFileName <- getDataFileName
+      text <- readFile dataFileName
+      let world = mkWorld text
+      let commands = mkCommands text
+      -- print world
+      -- print commands
+      putStrLn $ showWorld world
+      let bigWorld = enlarge world
+      putStrLn $ showBigWorld bigWorld
+      let world' = foldl' doBigCommand bigWorld commands
+      putStrLn $ showBigWorld world'
+      print $ gps world'
+      -- print $ gps world'
+      print $ part1 world commands
+      print $ part2 world commands
+
+part1 :: World -> [Position] -> Int
+part1 world commands = gps $ foldl' doCommand world commands
+-- part1 regions = sum $ fmap fenceCost $ distinctSets regions
+part2 world commands = gps $ foldl' doBigCommand bigWorld commands
+  where bigWorld = enlarge world
+
+doCommand :: World -> Position -> World
+doCommand world dir 
+  | there `S.member` world.walls = world
+  | there `S.member` world.boxes = fromMaybe world world'
+  | otherwise = world { robot = there }
+  where there = world.robot ^+^ dir
+        world' = do boxed <- moveBoxes world dir there
+                    return boxed { robot = there }      
+
+moveBoxes :: World -> Position -> Position -> Maybe World
+moveBoxes world dir box
+  | there `S.member` world.walls = Nothing
+  | there `S.member` world.boxes = world'
+  | otherwise = Just $ world { boxes = shift world.boxes }
+  where there = box ^+^ dir
+        world' = do boxedWorld <- moveBoxes world dir there
+                    let boxes' = shift boxedWorld.boxes
+                    return boxedWorld { boxes = boxes'}
+        shift bs =  S.insert there $ S.delete box bs
+
+
+gps :: World -> Int
+gps World { .. } = sum score
+  where rMax = S.findMax $ S.map (\(V2 r _) -> r) walls
+        cMax = S.findMax $ S.map (\(V2 _ c) -> c) walls
+        score = [ 100 * r + c
+                | c <- [0..cMax]  
+                , r <- [0..rMax] 
+                , V2 r c `elem` boxes
+                ]
+
+doBigCommand :: World -> Position -> World
+doBigCommand world dir 
+  | there `S.member` world.walls = world
+  | there `isBigBox` world.boxes = fromMaybe world rWorld
+  | otherwise = world { robot = there }
+  where there = world.robot ^+^ dir
+        movedBox = bigBoxActual world.boxes there
+        rWorld = do boxMoves <- moveBigBoxes world dir movedBox
+                    let froms = fmap fst boxMoves
+                    let tos = fmap snd boxMoves
+                    let boxes' = (S.fromList tos) `S.union` (world.boxes `S.difference` (S.fromList froms))
+                    let world' = world { boxes = boxes' }
+                    return world' { robot = there } 
+  
+
+moveBigBoxes :: World -> Position -> Position -> Maybe [Move]
+moveBigBoxes world dir box
+  | any (\t -> t `S.member` world.walls) there = Nothing
+  | any (\t -> t `isBigBox` world.boxes) there = allMoves
+  | otherwise = Just $ [ thisMove ]
+  where there = case dir of 
+                    U -> [box ^+^ U, box ^+^ R ^+^ U]
+                    D -> [box ^+^ D, box ^+^ R ^+^ D]
+                    L -> [box ^+^ L]
+                    R -> [box ^+^ R ^+^ R]
+                    _ -> []
+        thisMove = (box, box ^+^ dir)
+        allMoves = do let there' = nub $ fmap (bigBoxActual world.boxes) $ filter (\t -> t `isBigBox` world.boxes) there
+                      moves <- traverse (moveBigBoxes world dir) there'
+                      let moves' = concat moves
+                      return $ thisMove : moves'
+
+isBigBox :: Position -> Items -> Bool
+isBigBox here bs = S.member here bs || S.member (here ^+^ L) bs
+
+bigBoxActual :: Items -> Position -> Position
+bigBoxActual bs here
+  | here `S.member` bs = here 
+  | otherwise = here ^+^ L
+
+showWorld :: World -> String
+showWorld World { .. } = unlines rows
+  where rMax = S.findMax $ S.map (\(V2 r _) -> r) walls
+        cMax = S.findMax $ S.map (\(V2 _ c) -> c) walls
+        rows = [ [ if | V2 r c `elem` walls -> '#' 
+                      | V2 r c `elem` boxes -> 'O' 
+                      | V2 r c == robot -> '@' 
+                      | otherwise -> '.' 
+                  | c <- [0..cMax] ] 
+                | r <- [0..rMax] ]
+
+showBigWorld :: World -> String
+showBigWorld World { .. } = unlines rows
+  where rMax = S.findMax $ S.map (\(V2 r _) -> r) walls
+        cMax = S.findMax $ S.map (\(V2 _ c) -> c) walls
+        rows = [ [ if | V2 r c `elem` walls -> '#' 
+                      | V2 r c `elem` boxes -> '[' 
+                      | (V2 r c ^+^ L) `elem` boxes -> ']' 
+                      | V2 r c == robot -> '@' 
+                      | otherwise -> '.' 
+                  | c <- [0..cMax] ] 
+                | r <- [0..rMax] ]
+
+mkWorld :: String -> World
+mkWorld text = World { walls = walls, boxes = boxes, robot = robot }
+  where rows = takeWhile (not . null) $ lines text
+        rMax = length rows - 1
+        cMax = (length $ head rows) - 1
+        walls = S.fromList [ V2 r c | r <- [0..rMax], c <- [0..cMax], rows !! r !! c == '#' ]
+        boxes = S.fromList [ V2 r c | r <- [0..rMax], c <- [0..cMax], rows !! r !! c == 'O' ]
+        robot = head [ V2 r c | r <- [0..rMax], c <- [0..cMax], rows !! r !! c == '@' ]
+
+mkCommands :: String -> [Position]
+mkCommands text = fmap readDirection $ concat rows
+  where rows = tail $ dropWhile (not . null) $ lines text
+        readDirection '^' = U
+        readDirection 'v' = D
+        readDirection '<' = L
+        readDirection '>' = R
+
+enlarge :: World -> World
+enlarge World { .. } = World { walls = walls', boxes = boxes', robot = robot' }
+  where rMax = S.findMax $ S.map (\(V2 r _) -> r) walls
+        cMax = S.findMax $ S.map (\(V2 _ c) -> c) walls
+        walls' = S.unions $ S.map (\(V2 r c) -> S.fromList [V2 r (2 * c), V2 r (2 * c + 1)]) walls
+        boxes' = S.map (\(V2 r c) -> V2 r (2 * c)) boxes
+        V2 rr rc = robot
+        robot' = V2 rr (2 * rc)
\ No newline at end of file

diff --git a/adventofcode24.cabal b/adventofcode24.cabal
index 75d093ef4ce1ccb20933f05ce5717cf08dfba768..5519773433f58351a30ea72f55a7d4cd7e4a248e 100644 (file)
--- a/adventofcode24.cabal
+++ b/adventofcode24.cabal
@@ -153,4 +153,8 @@ executable advent14
   import: warnings, common-extensions, build-directives, common-modules
   main-is: advent14/Main.hs  
   build-depends: attoparsec, text, linear, lens
-  
\ No newline at end of file
+
+executable advent15
+  import: warnings, common-extensions, build-directives, common-modules
+  main-is: advent15/Main.hs  
+  build-depends: linear, containers