day 12
can you believe it guys? christmas is just 2 weeks away! i am so happy about this information
This commit is contained in:
parent
00062fcb2a
commit
9fe5b4e014
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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]
|
||||
Loading…
Reference in New Issue