2024-18 in haskellHEADmaster

1 files changed, 84 insertions, 0 deletions

diff --git a/2024/18-RAM_Run/second.hs b/2024/18-RAM_Run/second.hs
new file mode 100644
index 0000000..04c465c
--- /dev/null
+++ b/2024/18-RAM_Run/second.hs
@@ -0,0 +1,84 @@
+-- requires cabal install --lib megaparsec parser-combinators heap vector
+module Main (main) where
+
+import           Control.Monad        (void, when)
+import           Data.Functor
+import qualified Data.Heap            as H
+import qualified Data.List            as L
+import qualified Data.Map             as M
+import qualified Data.Vector          as V
+import           Data.Void            (Void)
+import           Text.Megaparsec
+import           Text.Megaparsec.Char
+
+exampleExpectedOutput = (6, 1)
+
+type Coord = (Int, Int)
+type Input = [Coord]
+
+type Parser = Parsec Void String
+
+parseNumber :: Parser Int
+parseNumber = read <$> some digitChar
+
+parseCoord :: Parser Coord
+parseCoord = (,) <$> parseNumber <* char ','
+                 <*> parseNumber <* eol
+
+parseInput' :: Parser Input
+parseInput' = some parseCoord <* eof
+
+parseInput :: String -> IO Input
+parseInput filename = do
+  input <- readFile filename
+  case runParser parseInput' filename input of
+    Left bundle  -> error $ errorBundlePretty bundle
+    Right input' -> return input'
+
+type Cost = Int
+data Position = Position Coord Cost deriving Show
+instance Ord Position where
+  compare (Position _ c1) (Position _ c2) = c1 `compare` c2
+instance Eq Position where
+ (Position p1 _ ) == (Position p2 _ ) = p1 == p2
+type Visited = M.Map Coord Cost
+type Maze = M.Map Coord ()
+
+type Candidates = H.MinHeap Position
+
+compute' :: Int -> Int -> Input -> Bool
+compute' size cutoff input = walk (M.singleton (0, 0) 0) $ H.singleton (Position (0, 0) 0)
+  where
+    walk :: Visited -> Candidates -> Bool
+    walk v h | H.isEmpty h = False
+             | x == size && y == size = True
+             | otherwise = walk v' $ H.union h' $ H.fromList n
+      where
+        ([pos@(Position p@(x, y) c)], h') = H.splitAt 1 h
+        n = nexts v pos
+        v' = L.foldl' (\acc (Position a b) -> M.insert a b acc) v n
+    nexts :: Visited -> Position -> [Position]
+    nexts v (Position p c) = L.filter (valid v) . map (\p' -> Position p' (c+1)) $ candidates p
+    valid :: Visited -> Position -> Bool
+    valid v (Position p@(x, y) c) = x >= 0 && x <= size && y >= 0 && y <= size && not (M.member p maze) && case M.lookup p v of
+      Just c' -> c < c'
+      Nothing -> True
+    candidates :: Coord -> [Coord]
+    candidates (x, y) = [ (x-1, y), (x+1, y), (x, y-1), (x, y+1) ]
+    maze = M.fromList $ zip (take cutoff input) (L.repeat ())
+
+compute :: Int -> Int -> Int -> Input -> Coord
+compute size n m input | mid == n = input L.!! n
+                       | valid = compute size mid m input
+                       | otherwise = compute size n mid input
+  where
+    mid = (n + (m - n) `div` 2)
+    valid = compute' size mid input
+
+main :: IO ()
+main = do
+  example <- parseInput "example"
+  let exampleOutput = compute 6 12 (length example) example
+  when  (exampleOutput /= exampleExpectedOutput)  (error $ "example failed: got " ++ show exampleOutput ++ " instead of " ++ show exampleExpectedOutput)
+  input <- parseInput "input"
+  print $ compute 70 1024 (length input) input