From 3fe1326396a11dd33581e0bc08ba6929007ecc90 Mon Sep 17 00:00:00 2001 From: Julien Dessaux Date: Sun, 3 Dec 2023 15:18:14 +0100 Subject: 2022-24 in haskell --- 2022/24-Blizzard_Basin/example | 7 +++ 2022/24-Blizzard_Basin/example2 | 6 +++ 2022/24-Blizzard_Basin/first.hs | 94 ++++++++++++++++++++++++++++++++++++++ 2022/24-Blizzard_Basin/input | 27 +++++++++++ 2022/24-Blizzard_Basin/second.hs | 99 ++++++++++++++++++++++++++++++++++++++++ 5 files changed, 233 insertions(+) create mode 100644 2022/24-Blizzard_Basin/example create mode 100644 2022/24-Blizzard_Basin/example2 create mode 100644 2022/24-Blizzard_Basin/first.hs create mode 100644 2022/24-Blizzard_Basin/input create mode 100644 2022/24-Blizzard_Basin/second.hs (limited to '2022') diff --git a/2022/24-Blizzard_Basin/example b/2022/24-Blizzard_Basin/example new file mode 100644 index 0000000..158014b --- /dev/null +++ b/2022/24-Blizzard_Basin/example @@ -0,0 +1,7 @@ +#.##### +#.....# +#>....# +#.....# +#...v.# +#.....# +#####.# diff --git a/2022/24-Blizzard_Basin/example2 b/2022/24-Blizzard_Basin/example2 new file mode 100644 index 0000000..685dc4f --- /dev/null +++ b/2022/24-Blizzard_Basin/example2 @@ -0,0 +1,6 @@ +#.###### +#>>.<^<# +#.<..<<# +#>v.><># +#<^v^^># +######.# diff --git a/2022/24-Blizzard_Basin/first.hs b/2022/24-Blizzard_Basin/first.hs new file mode 100644 index 0000000..b0e5f00 --- /dev/null +++ b/2022/24-Blizzard_Basin/first.hs @@ -0,0 +1,94 @@ +-- very slow with runghc, use ghc -O3 -o first first.hs +-- requires cabal install --lib megaparsec parser-combinators unordered-containers +module Main (main) where +import Control.Monad (void, when) +import Data.Functor +import Data.List qualified as L +import Data.Map qualified as M +import Data.Set qualified as S +import Data.Void (Void) +import Text.Megaparsec +import Text.Megaparsec.Char +import System.Exit (die) + +import Debug.Trace + +exampleExpectedOutput = 18 + +data Direction = N | S | E | W deriving Show +data Blizzard = Blizzard Int Int Direction deriving Show +data Input = Input { blizzards :: [Blizzard] + , height :: Int + , width :: Int + , xend :: Int + , xstart :: Int + } deriving Show + +type Parser = Parsec Void String + +findBlizzards :: (Int, [Blizzard]) -> String -> (Int, [Blizzard]) +findBlizzards (y, acc) line = (y+1, snd $ L.foldl' findBlizzards' (0, acc) line) + where + findBlizzards' :: (Int, [Blizzard]) -> Char -> (Int, [Blizzard]) + findBlizzards' (x, acc) '#' = (x+1, acc) + findBlizzards' (x, acc) '.' = (x+1, acc) + findBlizzards' (x, acc) '^' = (x+1, Blizzard x y N : acc) + findBlizzards' (x, acc) 'v' = (x+1, Blizzard x y S : acc) + findBlizzards' (x, acc) '>' = (x+1, Blizzard x y E : acc) + findBlizzards' (x, acc) '<' = (x+1, Blizzard x y W : acc) + +parseMapLine :: Parser String +parseMapLine = some (char '.' <|> char '#' <|> char '>' <|> char '<' <|> char '^' <|> char 'v') <* eol + +parseInput' :: Parser Input +parseInput' = do + lines <- some parseMapLine <* eof + let height = length lines + start = head lines + width = length start + Just xend = L.elemIndex '.' $ last lines + Just xstart = L.elemIndex '.' start + blizzards = snd $ L.foldl' findBlizzards (0, []) lines + return $ Input blizzards height width xend xstart + +parseInput :: String -> IO Input +parseInput filename = do + input <- readFile filename + case runParser parseInput' filename input of + Left bundle -> die $ errorBundlePretty bundle + Right input' -> return input' + +type Position = (Int, Int) + +compute :: Input -> Int +compute (Input blizzards height width xend xstart) = compute' 0 $ S.singleton (xstart, 0) + where + boundaries :: S.Set Position + boundaries = S.fromList (([(x, y)|x<-[0..width-1], y<-[0, height-1]] L.\\ [(xstart, 0), (xend, height-1)]) -- north and south walls + ++ [(x, y)|x<-[0, width-1], y<-[1..height-2]] -- east and west walls + ++ [(xstart, -1), (xend, height)]) -- to prevent escaping to the north and south + compute' :: Int -> S.Set Position -> Int + compute' i pos | (xend, height-1) `L.elem` pos = i + | otherwise = compute' (i+1) (step (i+1) pos) + step :: Int -> S.Set Position -> S.Set Position + step i = L.foldl' eval S.empty + where + eval :: S.Set Position -> Position -> S.Set Position + eval acc pos = S.union acc ((candidates pos S.\\ boundaries) S.\\ blizzards' i) + where + candidates :: Position -> S.Set Position + candidates (x, y) = S.fromList [(x-1, y), (x, y), (x+1, y), (x, y-1), (x, y+1)] + blizzards' i = S.fromList $ map (evalBlizzards i) blizzards + evalBlizzards :: Int -> Blizzard -> Position + evalBlizzards i (Blizzard x y N) = (x, ((y - i - 1) `mod` (height-2)) + 1) + evalBlizzards i (Blizzard x y S) = (x, ((y + i - 1) `mod` (height-2)) + 1) + evalBlizzards i (Blizzard x y E) = (((x + i - 1) `mod` (width-2)) + 1, y) + evalBlizzards i (Blizzard x y W) = (((x - i - 1) `mod` (width-2)) + 1, y) + +main :: IO () +main = do + example <- parseInput "example2" + let exampleOutput = compute example + when (exampleOutput /= exampleExpectedOutput) (die $ "example failed: got " ++ show exampleOutput ++ " instead of " ++ show exampleExpectedOutput) + input <- parseInput "input" + print $ compute input diff --git a/2022/24-Blizzard_Basin/input b/2022/24-Blizzard_Basin/input new file mode 100644 index 0000000..285925a --- /dev/null +++ b/2022/24-Blizzard_Basin/input @@ -0,0 +1,27 @@ +#.######################################################################################################################## +#<>v^<.^v><<.>v><<^^.v^>^v<^>.>^v>^>>v^v>><^><><<^><^>.^>^v>^>>^<^v.^<^v<.><.v><<.^v^.^<# +#<>.vv^^vv<^v.^><^v<>>.<<<.^<^<>vv>^vv..<<.^>^>>>.<>>^.^<^<<<^<>vv>.<<><^>.^>.vv^^v..v^v<^<^.<>^^v>^>v^<^># +#<<>v>v>v.^<><^><>^>.v<<>.^v.v<v<^^<<>^>vv^v^.<>>^^^^<>^<..><^>^<<^><^.v>>^>>>v>v>>vv^v<<.# +#<^.vv><^>^^>v<.>^vvv>v^v>>><^.>v^vv.^>>^>v>^.>><<^^vv^<<.v^<^v.v<<>><>>>.<<^^># +#<^vvvvvv^>>.^v>.<<^<^^<^>v><>>><>>vv^v><^>v>>v.^>>>v^v^^^.^^>^v<.v^>^^vvv^v>^v>>v<^^>>^^<><^>v.># +#.>v<<^v>^^<^v<^>vv^.<^vvv<^>^^vv^.v.^^..><<>^.>...^<<^>^^<^vvv>.^<>>^.v^v.^<>v^^.<>v>># +#>.^>.vv^<^^<><<>>>vv>.<><^^<>>v><<>>v^vv.>^.>v^^<^<^.>>v<<>.<^<><.<<^v^><>.<>^<<.^>^v<>^^>><<>vv.v<>v^^>>>>>v><# +#<.^<>.>.^>v><.^<>>>^^<^v^>^<^.>^^^v.<>vv><>v^v^v^^<^>^<<.v^>^v.<>.<^.>v><>>.<>v>>>.^<>^v<<<^^.v>v^<<# +#><^>.<<<^..>>>^>.>^<>>>^<.v<^^^><>v.>.v^v<^^v><^.^.><^^<>^^v<>><^<.v>><>>>>.>^v<^v^<<^v>>.v<^<>vv<>v>vv.^<<.^^<<>^^>>.^>^v>^>..>>>^v^v>>v>>v.^<>vv><>.<>vvvvv.vvv..><>v.vv<^v^v>^>^vv^>.>v^><^v^>>.>^v><<^^^>.v<>vvvv><<.^>><^.v>>^v<.v^<^v^.^^>^>>>.^.>vvv>>^^^^<^^v>^>v^<><<^v<<<><><<^vv^v<# +#<..vvv>><.v<^>^^v<<^v<>^><^v>^vvv^<^v>>^>>^^<<^v^v.^vv>^><^v<^v^v>vv>^<^^^v>^^^<.>^v.v^<^>>^>^^^^^^vv<.v^^><# +#<>^v<>>v^^v<^v<<><<^><^<<^^>.<.^v>^>>v<>^><.^<<<.>^^v^vvv><<^>>^^<^^<>>^v.>^<^^v<^># +#v<<><<^v^.^>><.v<^^^^>.><<><><<<^>v.>>>vv<.<>^v^>^^^^.>v^<>.v>^.v<^.v>vv<>># +#>v><>>^<^v>>v>v^>vv^v<^.vv^vv>v<<^v><>^<.>vvv...v<^><>>.^v>v<^^>v^v<<>v>.^>><<<><v># +#<<>^v>v>v<<v^..>..>^<>^>>><><<><^vv.>^v>v^v<<<<.>><<<<<.<<<>^>^>>>><.^.^^>v<^<^>>.^>>^v.<>^>v>># +#>v<<<>^^>..^>>v.v^<><^>^^<>^<<>v^.<^><.v>>vv^v>^^^>^v>^v^^v^>^.<^>>>v^<>^.<>>^^>>^><^>>.<<>>v>vv<># +#<^^^..>>><>v>v>.>^.<.vv.vv<>v^vv<<^^>>v<^^<^>>>>^^^><^^<.<^^>v>^^>vvv<^<..^>>>^v^v^^v>^^^.<.>v<^v><><>^^.># +#>^^>^^^^.<<.v^.><<><>.<<<^^><.>>..<>v^^^>^v<^>>.>v><^^vvv^>>^v><^<>^<>>^^v>^.v>v<<>>>^v^vv<<<^..<>^><>>^>.# +#.^<<<^^vv<.>v<.<>.>v.^..^^.>.vv.v>^>v.^.v<>v>>^^<^<^^^>>^>vvv.<^>><^>><^^>^>..^><..<^>^^v^v.>v<<>>vv^vv>v^<># +#<<>v<^<^.>..^<..^<^vv^v>v><>vv.vvv<^><^^>><>vv>^^^><>^<^^><^>.>v<>^.vvv<>^.>.^^v^># +#>v.^>..^>v>v>^^<^v>..>..^<.^..>>v<>.<>.>>vv^<<>>>v>v>v><<^v^>^^<>v.v<<^<.<><<<>.># +#>>v><..^^^.<<<<<^^^<>^^v^.>vv<<>>^^^...>^.<<^^v^..><>vv>v^>^v>.vvv^<><# +#>^v<..<>>v^v>v>v^v^<^<^^<..>^^>><<><>.^v.v<^>^<.^vv^.>v^>^v>^^v^>v<<<>><>>>^>^><^<# +#>><>>vv>>^^^v^^^>^>>><^vv><>>>^.v^>^>^vv<>>..^v.^^^vvvv<><^><^v>vv<<^vv>^>v..<><.>^^^v.v>vvvv>>>><.># +########################################################################################################################.# diff --git a/2022/24-Blizzard_Basin/second.hs b/2022/24-Blizzard_Basin/second.hs new file mode 100644 index 0000000..d11f3f4 --- /dev/null +++ b/2022/24-Blizzard_Basin/second.hs @@ -0,0 +1,99 @@ +-- very slow with runghc, use ghc -O3 -o second second.hs +-- requires cabal install --lib megaparsec parser-combinators unordered-containers +module Main (main) where +import Control.Monad (void, when) +import Data.Functor +import Data.List qualified as L +import Data.Map qualified as M +import Data.Set qualified as S +import Data.Void (Void) +import Text.Megaparsec +import Text.Megaparsec.Char +import System.Exit (die) + +import Debug.Trace + +exampleExpectedOutput = 54 + +data Direction = N | S | E | W deriving Show +data Blizzard = Blizzard Int Int Direction deriving Show +data Input = Input { blizzards :: [Blizzard] + , height :: Int + , width :: Int + , xend :: Int + , xstart :: Int + } deriving Show + +type Parser = Parsec Void String + +findBlizzards :: (Int, [Blizzard]) -> String -> (Int, [Blizzard]) +findBlizzards (y, acc) line = (y+1, snd $ L.foldl' findBlizzards' (0, acc) line) + where + findBlizzards' :: (Int, [Blizzard]) -> Char -> (Int, [Blizzard]) + findBlizzards' (x, acc) '#' = (x+1, acc) + findBlizzards' (x, acc) '.' = (x+1, acc) + findBlizzards' (x, acc) '^' = (x+1, Blizzard x y N : acc) + findBlizzards' (x, acc) 'v' = (x+1, Blizzard x y S : acc) + findBlizzards' (x, acc) '>' = (x+1, Blizzard x y E : acc) + findBlizzards' (x, acc) '<' = (x+1, Blizzard x y W : acc) + +parseMapLine :: Parser String +parseMapLine = some (char '.' <|> char '#' <|> char '>' <|> char '<' <|> char '^' <|> char 'v') <* eol + +parseInput' :: Parser Input +parseInput' = do + lines <- some parseMapLine <* eof + let height = length lines + start = head lines + width = length start + Just xend = L.elemIndex '.' $ last lines + Just xstart = L.elemIndex '.' start + blizzards = snd $ L.foldl' findBlizzards (0, []) lines + return $ Input blizzards height width xend xstart + +parseInput :: String -> IO Input +parseInput filename = do + input <- readFile filename + case runParser parseInput' filename input of + Left bundle -> die $ errorBundlePretty bundle + Right input' -> return input' + +type Position = (Int, Int) + +compute :: Input -> Int +compute (Input blizzards height width xend xstart) = let firstTrip = compute' 0 $ S.singleton (xstart, 0) + secondTrip = compute'' firstTrip $ S.singleton (xend, height - 1) + in compute' secondTrip $ S.singleton (xstart, 0) + where + boundaries :: S.Set Position + boundaries = S.fromList (([(x, y)|x<-[0..width-1], y<-[0, height-1]] L.\\ [(xstart, 0), (xend, height-1)]) -- north and south walls + ++ [(x, y)|x<-[0, width-1], y<-[1..height-2]] -- east and west walls + ++ [(xstart, -1), (xend, height)]) -- to prevent escaping to the north and south + compute' :: Int -> S.Set Position -> Int + compute' i pos | (xend, height-1) `L.elem` pos = i + | otherwise = compute' (i+1) (step (i+1) pos) + compute'' :: Int -> S.Set Position -> Int + compute'' i pos | (xstart, 0) `L.elem` pos = i + | otherwise = compute'' (i+1) (step (i+1) pos) + step :: Int -> S.Set Position -> S.Set Position + step i = L.foldl' eval S.empty + where + eval :: S.Set Position -> Position -> S.Set Position + eval acc pos = S.union acc ((candidates pos S.\\ boundaries) S.\\ blizzards' i) + where + candidates :: Position -> S.Set Position + candidates (x, y) = S.fromList [(x-1, y), (x, y), (x+1, y), (x, y-1), (x, y+1)] + blizzards' i = S.fromList $ map (evalBlizzards i) blizzards + evalBlizzards :: Int -> Blizzard -> Position + evalBlizzards i (Blizzard x y N) = (x, ((y - i - 1) `mod` (height-2)) + 1) + evalBlizzards i (Blizzard x y S) = (x, ((y + i - 1) `mod` (height-2)) + 1) + evalBlizzards i (Blizzard x y E) = (((x + i - 1) `mod` (width-2)) + 1, y) + evalBlizzards i (Blizzard x y W) = (((x - i - 1) `mod` (width-2)) + 1, y) + +main :: IO () +main = do + example <- parseInput "example2" + let exampleOutput = compute example + when (exampleOutput /= exampleExpectedOutput) (die $ "example failed: got " ++ show exampleOutput ++ " instead of " ++ show exampleExpectedOutput) + input <- parseInput "input" + print $ compute input -- cgit v1.2.3