2022-24 in haskell
This commit is contained in:
parent
2a186bbc08
commit
3fe1326396
GPG key ID:
F92E51B86E07177E
5 changed files with 233 additions and 0 deletions
7
2022/24-Blizzard_Basin/example
Normal file
7
2022/24-Blizzard_Basin/example
Normal file
|
|
@ -0,0 +1,7 @@
|
||||||
|
#.#####
|
||||||
|
#.....#
|
||||||
|
#>....#
|
||||||
|
#.....#
|
||||||
|
#...v.#
|
||||||
|
#.....#
|
||||||
|
#####.#
|
||||||
6
2022/24-Blizzard_Basin/example2
Normal file
6
2022/24-Blizzard_Basin/example2
Normal file
|
|
@ -0,0 +1,6 @@
|
||||||
|
#.######
|
||||||
|
#>>.<^<#
|
||||||
|
#.<..<<#
|
||||||
|
#>v.><>#
|
||||||
|
#<^v^^>#
|
||||||
|
######.#
|
||||||
94
2022/24-Blizzard_Basin/first.hs
Normal file
94
2022/24-Blizzard_Basin/first.hs
Normal file
|
|
@ -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
|
||||||
27
2022/24-Blizzard_Basin/input
Normal file
27
2022/24-Blizzard_Basin/input
Normal file
|
|
@ -0,0 +1,27 @@
|
||||||
|
#.########################################################################################################################
|
||||||
|
#<>v^<vv<v<><.^v><<.>v><<^^<v..<>.v^>^v<^><vv>.>^v>^>>v^v>><^><><<^><^>.^>^<vv>v>^>>^<^v.^<^v<.><.v><<.^v^.^<v^v<<vv><<v>#
|
||||||
|
#<>.vv^^vv<^v.^><^v<>>.<<<.^<^<>v<v<<>v>^vv..<<.^>^>>>.<>>^.^<^<<<^<>vv>.<<><^>.^>.vv^^v..v^<v^<vv.^.>v<^<^.<>^^v>^>v^<^>#
|
||||||
|
#<<>v>v>v.^<><^><>^>.v<<>.^v.v<<v<^^v>v<^^<<>^>vv<vvv>^v^.<>>^^^^<><vvv<v^>^<vv.><..><^>^<<^><^.v>>^>>>v>v>>vv^v<<.<v^<^>#
|
||||||
|
#<^.vv><^>^^>v<.>^vvv>v^v>><v>><v<><^.>v^v<v<<<>v.^>>^>v>^.>><<<v.^^^v^.v>^^vv^<<.v^<^v.v<<>><><vv.vv<^..<vv^.^<>>>.<<^^>#
|
||||||
|
#<^<v<.>vvvvvv^>>.^v>.<<v^^^><^<^^<^>v><>>><>>vv^v><^>v>>v.^>>>v^v^^^.^^>^v<.v^>^^v<vv.<.<^v>vv^v>^v>>v<^^>>^^<><^>v<v>.>#
|
||||||
|
#<vvvv<<^<v^vvv<.^<vv>.>v<v><<^v>^^<^v<^>vv^.<^vvv<^>^^vv^.v.^^..><<>^.>...^<<^>^^<^vvv>.^<>>^.v^v.^<>v^<vvvv>^.<>v>><v<>#
|
||||||
|
#>.^>.vv^<^^<v><><<>>>vv>.<><^^<>>v><<>>v^vv.>^.>v^^<^<^.>>v<<<vv<<>>.<^<><.<<^v^><>.<>^<<.^>^v<>^^>><<>vv.v<>v^^>>>>>v><#
|
||||||
|
#<.^<>.>.^>v><.^<>>>^^<^v^>^<^.>^^^v.<>vv><>v^v^v^^<^>^<<.v^>^v.<>.<^.>v><>>.<<v<^>>v>>>.^<><v<vv.<^^>^v<<<^^.<v<^>v>v^<<#
|
||||||
|
#><^>.<<<^..>>>^>.>^<vv.<.v^><>>>^<.v<^^^><>v.>.v^v<^^v><^.^.><^^<>^^v<>><^<.v>><>>>>.>^v<^v^<<^v>>.v<^<>vv<>v>vv.^<<<v.<#
|
||||||
|
#>.^^<<><v.>^^>>.^>^v>^>..>>>^v^<v^^^>v>>v>>v.^<>vv><>.<>vvvvv.vvv..><>v.vv<^v^v>^>^vv^<v<.^>>.>v^><<v>^v^>>.>^v><<^^^<v<#
|
||||||
|
#.^<>>.v<>vv<vvv^^>vv><<.^>><^.v>>^v<.v^<^v^.<vvv^^>^^>^>>>.^.>vvv>>^^^^<^^v>^>v^<v><v^<><><<^v<<<><><<v^.vv><^vv^v<<vv<>#
|
||||||
|
#<..vvv>><.v<^><v.v^^^v>^^v<<^v<>^><^v>^vvv^<^v>>^>>^<v>^<<^v^v.^vv>^><^v<^v^v>vv>^<^^^v>^^^<.>^v.v^<^>>^>^^^^^^vv<.v^^><#
|
||||||
|
#<v><<v>>^v<>>v^^v<^v<<><<^><^<<^^>.<.^v>^>>v<>^><.^<<<.>^^v^vvv><<^>>^^<^^<><v.^v<<^..v^.<v>>^v.>^<^^v<<vvv^v<^<<<<<v>^>#
|
||||||
|
#<v<<v^<^<^^v^vv<<<.>v<<><<^v^.^>><.v<^<v<^<<<<.<v^^vvv^>^^^>.><<><><<<^>v.>>>vv<.<v.><>^v^>^^^^.>v^<>.v>^.<v>v<^.v>vv<>>#
|
||||||
|
#>v<v..<^v^<<<>><>>^<^v>>v>v^>vv^v<^.vv^vv>v<<<vv.v^.>^v><<v<vv>>^<.>vvv...v<^><>>.^v>v<^^>v^v<<>v>.^>><<<><<v^<v^.^v^>v>#
|
||||||
|
#<<>^v>v>v<<<vvvv^^>v^..>..>^<>^>>><><<><v><^vv.>^v>v^v<<<vv><<.>><<<<<.<<<>^><v><vv^^v>^>>>><.^.^^>v<^<^>>.^>>^v.<>^>v>>#
|
||||||
|
#>v<<<>^^>..^>>v.v^<><^>^^<<vv<<>>^<<>v^.<^><.v>>vv^v<v<^^v..>>^^^>^v>^v^^v^>^.<^>>>v^<><v>^.<>>^^<vv>>>^><^>>.<<>>v>vv<>#
|
||||||
|
#<^^^..>>><>v>v>.>^.<.vv.vv<>v^vv<<^^>>v<^^<vv><^>><v>>>^^^><^^<.<^^>v>^^><v<vv^>vvv<^<..^>>>^v^v^^v>^^^.<.>v<^v><><>^^.>#
|
||||||
|
#>^^>^^^^.<<.v^.><v<^^.<<<.><<><>.<<<^^><.>>..<>v^^^>^v<^>>.>v><^^vvv^>>^<v>v><^<>^<>>^^v>^.v>v<<>>>^v^vv<<<^..<>^><>>^>.#
|
||||||
|
#.^<<<^^vv<.>v<.<>.>v.^..^^.>.vv.v>^>v.^.v<>v>>^^<^<^^^>>^>vvv.<^>><^>><^^>^>..^><.<v>.<^>^^v^v.>v<v^^><<>>vv^vv><v<>v^<>#
|
||||||
|
#<vvv><<>v<^<^.>..^<.<v^v^v>.^<^vv^v>v<vvv<>><>vv.vvv<^><^^>><>vv>^^^><>^<^^><^>.>v<>^.vv<v<<v^^>v<v.^^^><>^<v^<>.>.^^v^>#
|
||||||
|
#>v.^>..^>v>v>^^<^v>..>..^<.^..>>v<>.<>.<v>>>vv^<<>>>v<v^v^^vv<^vvvv<^v<^v<^^>>v>v><v><<v><v><^v<v>^>^^<>v.v<<^<.<><<<>.>#
|
||||||
|
#>>v><..^^^.<v<^^<v<><<<<<^^^<>^^v^.>vv<v><<>>^^^<v^vv^v^<>...>^.<v><<^^v^..><>vv>v^>^v>.vv<v<^.<<<v^<^v^<<v^.<.^<.>v^<><#
|
||||||
|
#>^v<..<>>v^v>v>v^v^<^<^^<..><v>^^>><<><>.^v.v<^>^<v><.^vv^.>v^>^v>^^v^>v<v^...><<<>><>>>^<vv<<^^^.<^vv^^^.v<vv<<<>>^><^<#
|
||||||
|
#>><<v<>>>vv>>^^^v^^^>^>><v<>><^vv><>>>^.v^>^>^vv<>>..^v.^^^vvvv<><^><^v>vv<<^vv>^>v..<><.>^^^v.v>vvvv>>>><<vv<>.<v^<vv>>#
|
||||||
|
########################################################################################################################.#
|
||||||
99
2022/24-Blizzard_Basin/second.hs
Normal file
99
2022/24-Blizzard_Basin/second.hs
Normal file
|
|
@ -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
|
||||||
Loading…
Add table
Reference in a new issue