From 9fe5b4e014b7a3b99b599ad3b8239c0009c34f8d Mon Sep 17 00:00:00 2001 From: "Jill \"oatmealine\" Monoids" Date: Mon, 12 Dec 2022 17:51:56 +0300 Subject: [PATCH] day 12 can you believe it guys? christmas is just 2 weeks away! i am so happy about this information --- 12-a.hs | 100 ++++++++++++++++++++++++++++++++++++++++++++++++ 12-b.hs | 114 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ AStar.hs | 76 +++++++++++++++++++++++++++++++++++++ 3 files changed, 290 insertions(+) create mode 100644 12-a.hs create mode 100644 12-b.hs create mode 100644 AStar.hs diff --git a/12-a.hs b/12-a.hs new file mode 100644 index 0000000..00e7885 --- /dev/null +++ b/12-a.hs @@ -0,0 +1,100 @@ +import Prelude hiding (Left, Right) +import AStar +import Data.List (findIndex, elemIndex) +import Data.Maybe (fromJust) +import GHC.Utils.Misc (uncurry3) +import Data.Char () + +data Elevation = A | B | C | D | E | F | G | H | I | J | K | L | M | N | O | P | Q | R | S | T | U | V | W | X | Y | Z + deriving (Show, Eq, Enum, Bounded) + +data Direction = Left | Down | Up | Right + deriving (Show, Eq) + +directionToChar Left = '<' +directionToChar Down = 'v' +directionToChar Up = '^' +directionToChar Right = '>' + +type Pos = (Int, Int) +type Grid a = [[a]] + +directionTo :: Pos -> Pos -> Direction +directionTo (x1, y1) (x2, y2) + | x2 > x1 = Right + | x2 < x1 = Left + | y2 > y1 = Down + | y2 < y1 = Up + | otherwise = undefined + +(!!!) :: Grid a -> Pos -> a +(!!!) grid (x, y) = grid !! y !! x + +-- stolen from https://hackage.haskell.org/package/relude-1.1.0.0/docs/src/Relude.List.html#%21%21%3F +-- (!!) but maybe monad (real) +infix 9 !!? +(!!?) :: [a] -> Int -> Maybe a +(!!?) xs i + | i < 0 = Nothing + | otherwise = go i xs + where + go :: Int -> [a] -> Maybe a + go 0 (x:_) = Just x + go j (_:ys) = go (j - 1) ys + go _ [] = Nothing + +findPos :: (Eq a) => a -> Grid a -> Maybe Pos +findPos target grid = do + y <- findIndex (target `elem`) grid + x <- elemIndex target (grid !! y) + Just (x, y) + +gridMap :: (a -> b) -> Grid a -> Grid b +gridMap f = map (map f) + +gridWidth :: Grid a -> Int +gridWidth = length . head +gridHeight :: Grid a -> Int +gridHeight = length + +parseElevation :: Char -> Elevation +parseElevation 'S' = A +parseElevation 'E' = Z +parseElevation x = toEnum (fromEnum x - 97) + +parseGrid :: String -> (Grid Elevation, Pos, Pos) +parseGrid g = (gridMap parseElevation gridChars, fromJust start, fromJust end) + where + start = findPos 'S' gridChars + end = findPos 'E' gridChars + gridChars = lines g + +showGrid :: (Show a) => Grid a -> String +showGrid = unlines . map (concatMap show) + +isValidTravel :: Grid Elevation -> Pos -> Pos -> Bool +isValidTravel grid (x1, y1) (x2, y2) + | x2 < 0 || x2 >= gridWidth grid || y2 < 0 || y2 >= gridHeight grid = False + | otherwise = diff <= 1 + where + diff = height2 - height1 + height1 = fromEnum $ grid !!! (x1, y1) + height2 = fromEnum $ grid !!! (x2, y2) + +getAdjacentPositions :: Grid Elevation -> Pos -> [(Pos, Int)] +getAdjacentPositions grid (x, y) = zip validPositions [1000000000..] -- spent about an hour debugging for this to be the fix + where + validPositions = filter (isValidTravel grid (x, y)) allPositions + allPositions = [(x, y + 1), (x, y - 1), (x + 1, y), (x - 1, y)] + thisHeight = fromEnum $ grid !!! (x, y) + +distance :: Pos -> Pos -> Int +distance (x1, y1) (x2, y2) = abs (x1 - x2) + abs (y1 - y2) + +pathfind :: Grid Elevation -> Pos -> Pos -> Maybe (Int, [Pos]) +pathfind grid start end = astarSearch start (== end) (getAdjacentPositions grid) (distance end) + +main = interact $ + show + . flip (-) 1 . length . snd . fromJust . uncurry3 pathfind + . parseGrid \ No newline at end of file diff --git a/12-b.hs b/12-b.hs new file mode 100644 index 0000000..02ee549 --- /dev/null +++ b/12-b.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE TupleSections #-} + +import Prelude hiding (Left, Right) +import AStar +import Data.List (findIndex, elemIndex) +import Data.Maybe (fromJust, mapMaybe) +import GHC.Utils.Misc (uncurry3) + +data Elevation = A | B | C | D | E | F | G | H | I | J | K | L | M | N | O | P | Q | R | S | T | U | V | W | X | Y | Z + deriving (Show, Eq, Enum, Bounded) + +data Direction = Left | Down | Up | Right + deriving (Show, Eq) + +directionToChar Left = '<' +directionToChar Down = 'v' +directionToChar Up = '^' +directionToChar Right = '>' + +type Pos = (Int, Int) +type Grid a = [[a]] + +directionTo :: Pos -> Pos -> Direction +directionTo (x1, y1) (x2, y2) + | x2 > x1 = Right + | x2 < x1 = Left + | y2 > y1 = Down + | y2 < y1 = Up + | otherwise = undefined + +(!!!) :: Grid a -> Pos -> a +(!!!) grid (x, y) = grid !! y !! x + +-- stolen from https://hackage.haskell.org/package/relude-1.1.0.0/docs/src/Relude.List.html#%21%21%3F +-- (!!) but maybe monad (real) +infix 9 !!? +(!!?) :: [a] -> Int -> Maybe a +(!!?) xs i + | i < 0 = Nothing + | otherwise = go i xs + where + go :: Int -> [a] -> Maybe a + go 0 (x:_) = Just x + go j (_:ys) = go (j - 1) ys + go _ [] = Nothing + +findPos :: (Eq a) => a -> Grid a -> Maybe Pos +findPos target grid = do + y <- findIndex (target `elem`) grid + x <- elemIndex target (grid !! y) + Just (x, y) + +gridMap :: (a -> b) -> Grid a -> Grid b +gridMap f = map (map f) + +allGridPositions :: Grid a -> [Pos] +allGridPositions grid = concatMap (\y -> map (, y) [0 .. gridWidth grid - 1]) [0 .. gridHeight grid - 1] + +gridWidth :: Grid a -> Int +gridWidth = length . head +gridHeight :: Grid a -> Int +gridHeight = length + +parseElevation :: Char -> Elevation +parseElevation 'S' = A +parseElevation 'E' = Z +parseElevation x = toEnum (fromEnum x - 97) + +parseGrid :: String -> (Grid Elevation, Pos, Pos) +parseGrid g = (gridMap parseElevation gridChars, fromJust start, fromJust end) + where + start = findPos 'S' gridChars + end = findPos 'E' gridChars + gridChars = lines g + +showGrid :: (Show a) => Grid a -> String +showGrid = unlines . map (concatMap show) + +isValidTravel :: Grid Elevation -> Pos -> Pos -> Bool +isValidTravel grid (x1, y1) (x2, y2) + | x2 < 0 || x2 >= gridWidth grid || y2 < 0 || y2 >= gridHeight grid = False + | otherwise = diff <= 1 + where + diff = height2 - height1 + height1 = fromEnum $ grid !!! (x1, y1) + height2 = fromEnum $ grid !!! (x2, y2) + +getAdjacentPositions :: Grid Elevation -> Pos -> [(Pos, Int)] +getAdjacentPositions grid (x, y) = zip validPositions [1000000000..] -- spent about an hour debugging for this to be the fix + where + validPositions = filter (isValidTravel grid (x, y)) allPositions + allPositions = [(x, y + 1), (x, y - 1), (x + 1, y), (x - 1, y)] + thisHeight = fromEnum $ grid !!! (x, y) + +distance :: Pos -> Pos -> Int +distance (x1, y1) (x2, y2) = abs (x1 - x2) + abs (y1 - y2) + +pathfind :: Grid Elevation -> Pos -> Pos -> Maybe (Int, [Pos]) +pathfind grid start end = astarSearch start (== end) (getAdjacentPositions grid) (distance end) + +findShortestSteps :: Grid Elevation -> Pos -> Pos -> Maybe Int +findShortestSteps grid start end = flip (-) 1 . length . snd <$> pathfind grid start end + +-- hacky way of doing this; you'd preferably pathfind from the end to any `a` but i didn't want to write a heuristic for that so oh well +findShortestStart :: Grid Elevation -> Pos -> Int +findShortestStart grid end = minimum $ mapMaybe (flip (findShortestSteps grid) end) possibleStartPositions + where + possibleStartPositions = filter ((== A) . (grid !!!)) allPositions + allPositions = allGridPositions grid + +main = interact $ + show + . (\(grid, _, end) -> findShortestStart grid end) + . parseGrid \ No newline at end of file diff --git a/AStar.hs b/AStar.hs new file mode 100644 index 0000000..a669f36 --- /dev/null +++ b/AStar.hs @@ -0,0 +1,76 @@ +-- https://gist.github.com/abhin4v/8172534 + +module AStar where + +import qualified Data.PQueue.Prio.Min as PQ +import qualified Data.HashSet as Set +import qualified Data.HashMap.Strict as Map +import Data.Hashable (Hashable) +import Data.List (foldl') +import Data.Maybe (fromJust) + +{- cabal: +build-depends: base, pqueue, unordered-containers, hashable +-} + +-- A* search: Finds the shortest path from a start node to a goal node using a heuristic function. +astarSearch :: (Eq a, Hashable a) => + a -- startNode: the node to start the search from + -> (a -> Bool) -- isGoalNode: a function to test if a node is the goal node + -> (a -> [(a, Int)]) -- nextNodeFn: a function which calculates the next nodes for a current node + -- along with the costs of moving from the current node to the next nodes + -> (a -> Int) -- heuristic: a function which calculates the (approximate) cost of moving + -- from a node to the nearest goal node + -> Maybe (Int, [a]) -- result: Nothing is no path is found else + -- Just (path cost, path as a list of nodes) +astarSearch startNode isGoalNode nextNodeFn heuristic = + astar (PQ.singleton (heuristic startNode) (startNode, 0)) + Set.empty (Map.singleton startNode 0) Map.empty + where + -- pq: open set, seen: closed set, tracks: tracks of states + astar pq seen gscore tracks + -- If open set is empty then search has failed. Return Nothing + | PQ.null pq = Nothing + -- If goal node reached then construct the path from the tracks and node + | isGoalNode node = Just (gcost, findPath tracks node) + -- If node has already been seen then discard it and continue + | Set.member node seen = astar pq' seen gscore tracks + -- Else expand the node and continue + | otherwise = astar pq'' seen' gscore' tracks' + where + -- Find the node with min f-cost + (node, gcost) = snd . PQ.findMin $ pq + + -- Delete the node from open set + pq' = PQ.deleteMin pq + + -- Add the node to the closed set + seen' = Set.insert node seen + + -- Find the successors (with their g and h costs) of the node + -- which have not been seen yet + successors = + filter (\(s, g, _) -> + not (Set.member s seen') && + (not (s `Map.member` gscore) + || g < (fromJust . Map.lookup s $ gscore))) + $ successorsAndCosts node gcost + + -- Insert the successors in the open set + pq'' = foldl' (\q (s, g, h) -> PQ.insert (g + h) (s, g) q) pq' successors + + gscore' = foldl' (\m (s, g, _) -> Map.insert s g m) gscore successors + + -- Insert the tracks of the successors + tracks' = foldl' (\m (s, _, _) -> Map.insert s node m) tracks successors + + -- Finds the successors of a given node and their costs + successorsAndCosts node gcost = + map (\(s, g) -> (s, gcost + g, heuristic s)) . nextNodeFn $ node + + + -- Constructs the path from the tracks and last node + findPath tracks node = + if Map.member node tracks + then findPath tracks (fromJust . Map.lookup node $ tracks) ++ [node] + else [node] \ No newline at end of file