From 749637707e75021bc067ef14b0e3adeb44a9002c Mon Sep 17 00:00:00 2001 From: toastyandwarm Date: Mon, 16 Dec 2024 18:48:34 +0000 Subject: [PATCH] day 16 --- 16/solution.hs | 168 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 168 insertions(+) create mode 100644 16/solution.hs diff --git a/16/solution.hs b/16/solution.hs new file mode 100644 index 0000000..3c21b25 --- /dev/null +++ b/16/solution.hs @@ -0,0 +1,168 @@ +import Data.List +import Data.Graph +import Data.Maybe +import Data.Array +import Debug.Trace + +data Square = Wall | Square {visited :: Bool, dir :: Maybe Direction, distance :: Maybe Int, start :: Bool, end :: Bool} + +data Direction = DirUp | DirDown | DirLeft | DirRight deriving Eq + +instance Show Square where + show Wall = "#" + show Square {dir=Just x} = show x + show Square {dir=Nothing} = "." + +instance Show Direction where + show x + | x == DirUp = "^" + | x == DirDown = "v" + | x == DirLeft = "<" + | x == DirRight = ">" + +toSquare :: Char -> Maybe Square +toSquare '#' = Just Wall +toSquare '.' = Just Square {visited=False, dir=Nothing, distance=Nothing, start=False, end=False} +toSquare 'S' = Just Square {visited=True, dir=Just DirRight, distance=Just 0, start=True, end=False} +toSquare 'E' = Just Square {visited=False, dir=Nothing, distance=Nothing, start=False, end=True} +toSquare _ = Nothing + +toDirection :: Char -> Maybe Direction +toDirection '^' = Just DirUp +toDirection 'v' = Just DirDown +toDirection '<' = Just DirLeft +toDirection '>' = Just DirRight +toDirection _ = Nothing + +addDir :: Direction -> (Int, Int) -> (Int, Int) +addDir dir (x, y) = case dir of + DirUp -> (x-1, y) + DirDown -> (x+1, y) + DirLeft -> (x, y-1) + DirRight -> (x, y+1) + +traceOut :: Show a => a -> a +traceOut x = (traceShow x x) + +addFirst :: [[a]] -> a -> [[a]] +addFirst [] x = [[x]] +addFirst (y:ys) x = ([x] ++ y) : ys + +split :: [Char] -> String -> [String] +split _ [] = [] +split delims (x:xs) + | elem x delims = [[]] ++ split delims xs + | otherwise = addFirst (split delims xs) x + +splitInput :: String -> [[Char]] +splitInput = split ['\n'] + +makeGraph :: [[Char]] -> (Graph, (Vertex -> ((Int, Int), (Int, Int), [(Int, Int)])), ((Int, Int) -> Maybe Vertex)) +makeGraph grid = graphFromEdgeList grid . concat . map (\(x, _) -> x) . concat . flipSecond . map (map (\(x, row) -> foldl' (combine x) ([], (-1, '#')) row)) . map (indexed . map indexed) . (\x -> [x, transpose x]) $ grid + +graphFromEdgeList :: [[Char]] -> [((Int, Int), (Int, Int))] -> (Graph, (Vertex -> ((Int, Int), (Int, Int), [(Int, Int)])), ((Int, Int) -> Maybe Vertex)) +graphFromEdgeList grid edgePairs = + graphFromEdges [((x, y), (x, y), [b | (a, b) <- edgePairs, a == (x, y)]) | (x, row) <- indexed grid, (y, value) <- indexed row] + +makeArray :: [[Char]] -> (Array (Int, Int) Square) +makeArray grid = listArray ((0, 0), ((length grid)-1, (length (grid!!0))-1)) . concat . map (map (fromJust . toSquare)) $ grid + +combine :: Int -> ([((Int, Int), (Int, Int))], (Int, Char)) -> (Int, Char) -> ([((Int, Int), (Int, Int))], (Int, Char)) +combine x (edges, (prevy, prevv)) (nexty, nextv) + | condition = ((((x, prevy), (x, nexty)):((x, nexty), (x, prevy)):edges), (nexty, nextv)) + | otherwise = (edges, (nexty, nextv)) + where condition = (prevv == '.' || prevv == 'E' || prevv == 'S') && (nextv == '.' || nextv == 'E' || nextv == 'S') + +flipSecond :: [[([((Int, Int), (Int, Int))], (Int, Char))]] -> [[([((Int, Int), (Int, Int))], (Int, Char))]] +flipSecond [a, xs] = [a, map (\(x, y) -> ((map (\((a, b), (c, d)) -> ((b, a), (d, c))) x), y)) xs] + +indexed :: [a] -> [(Int, a)] +indexed xs = zip [0..] xs + +printGrid :: (Array (Int, Int) Square) -> String +printGrid arr = concat $ [concat [show (arr!(x, y)) | y <- [0..140]] ++ "\n" | x <- [0..23]] ++ ["\n\n"] ++ [concat [show (arr!(x, y)) | y <- [0..140]] ++ "\n" | x <- [117..140]] +--printGrid arr = concat $ [concat [show (arr!(x, y)) | y <- [0..14]] ++ "\n" | x <- [0..14]] + +type ArrayGrid = Array (Int, Int) Square +type GFunc = (Vertex -> ((Int, Int), (Int, Int), [(Int, Int)])) +type GFunc2 = ((Int, Int) -> Maybe Vertex) + +-- getDir from to +getDir :: (Int, Int) -> (Int, Int) -> Maybe Direction +getDir (a, b) (c, d) = case (a-c, b-d) of + (1, 0) -> Just DirUp + (-1, 0) -> Just DirDown + (0, 1) -> Just DirLeft + (0, -1) -> Just DirRight + _ -> Nothing + +getUpdate :: ArrayGrid -> (Int, Int) -> (Int, Int) -> [((Int, Int), Square)] +getUpdate arr coord neighbour = case distance toSquare of + Nothing -> [newSquare] + Just x -> case compare x newDist of + EQ -> undefined + GT -> [newSquare] + LT -> [] + where fromSquare = arr!coord + dirMove = fromJust $ getDir coord neighbour + toSquare = arr!neighbour + newDist = (if (fromJust $ dir $ fromSquare) == (dirMove) then (+1) else (+1001)) $ fromJust $ distance fromSquare + newSquare = (neighbour, Square {visited=True, dir=Just dirMove, distance=Just newDist, start=start toSquare, end=end toSquare}) + +updateArray :: ArrayGrid -> Graph -> GFunc -> GFunc2 -> [(Int, Int)] -> (ArrayGrid, [(Int, Int)]) +updateArray arr graph gfunc gfunc2 = (\x -> (doUpdate arr x, map (\(a, _) -> a) x)) . concat . concat . map (\(coord, neighbours) -> map (getUpdate arr coord) neighbours) . map (\coord -> let (_, _, neighbours) = gfunc $ fromJust $ gfunc2 coord in (coord, neighbours)) + +doUpdate :: ArrayGrid -> [((Int, Int), Square)] -> ArrayGrid +doUpdate arr [] = arr +doUpdate arr ((update@(pos, square)):updates) = case distance (arr!pos) of + Nothing -> doUpdate (arr // [update]) updates + Just x -> case compare x (fromJust $ distance square) of + EQ -> doUpdate arr updates + GT -> doUpdate (arr // [update]) updates + LT -> doUpdate arr updates + +findStart :: ArrayGrid -> (Int, Int) +findStart = (\(a, _) -> a) . head . filter (\(_, b) -> case b of + Wall -> False + Square {start=s} -> s) . assocs +findEnd :: ArrayGrid -> (Int, Int) +findEnd = (\(a, _) -> a) . head . filter (\(_, b) -> case b of + Wall -> False + Square {end=e} -> e) . assocs + +iterArray :: ArrayGrid -> Graph -> GFunc -> GFunc2 -> [(Int, Int)] -> ArrayGrid +iterArray arr graph gfunc gfunc2 coords = case (nub newCoords) of + [] -> newArray + _ -> iterArray newArray graph gfunc gfunc2 newCoords + where (newArray, newCoords) = updateArray (trace (printGrid arr) arr) graph gfunc gfunc2 coords + +solve1 :: ArrayGrid -> Int +solve1 arr = fromJust $ distance $ traceOut $ arr!(findEnd arr) + +solve2 :: ArrayGrid -> ArrayGrid -> Int -> Int +solve2 arr1 arr2 target = length $ (\x -> trace (test arr1 x) x) $ filter (\x -> case (arr1!x, arr2!x) of + (Square {distance=a}, Square {distance=b}) -> elem (traceOut ((fromJust a) + (fromJust b))) [target, target+1000, target-1000] + _ -> False + ) $ indices arr1 + +test :: (Array (Int, Int) Square) -> [(Int, Int)] -> String +test arr matches = concat $ [concat [if (elem (x, y) matches) then "O" else case (arr!(x, y)) of + Wall -> "#" + _ -> " " + | y <- [0..140]] ++ "\n" | x <- [0..140]] + +main :: IO() +main = do + fileinp <- readFile "input.txt" + let parsed = splitInput fileinp + let (graph, gfunc, gfunc2) = makeGraph parsed +-- print graph + let array = makeArray parsed +-- putStrLn $ printGrid array + let solvedStart = iterArray array graph gfunc gfunc2 [findStart array] + let solvedEnd = iterArray (array // [(findStart array, Square {visited=False, dir=Nothing, distance=Nothing, start=True, end=False}), + (findEnd array, Square {visited=True, dir=(dir $ (solvedStart!) $ findEnd solvedStart), distance=Just 0, start=False, end=True})]) graph gfunc gfunc2 [findEnd array] + let solved1 = solve1 solvedStart + let solved2 = solve2 solvedStart solvedEnd solved1 + print solved1 + print solved2