/wakamoleguy

It's Day 12, and it's finally Dijkstra time! We need to find the shortest path on the graph, so let's get right to it. In past years, I've used a library for Dijkstra's, but this year I tried to roll it myself. Let's see how that worked out!

Dijkstra's in Haskell

Dijkstra's Algorithm is an algorithm for finding the shortest distance between any two points on a graph. I'm not going to explain it much here, as there are many better resources for that.

In implementing Dijkstra's, there are two pieces of state we care about: our queue of upcoming nodes to visit, and our set of nodes already visited (which we do not want to waste time revisting). With today's simple problem, I used a Sequence and a Set (Haskell's Set is tree-based). There are better data types for this! But these were simple and efficient enough.

Dijkstra's is a recursive function, so we can keep track of our state by passing it from one recursive call to the next. Here is the meat of the algorithm:

go :: Array (Int, Int) Char -> Set (Int, Int) -> Seq ((Int, Int), Int) -> Int
go g v q = case Seq.viewl q of
  (i, d) :< q' ->
    if i `elem` v
      then go g v q'
      else
        if i == goal g
          then d
          else go g (i `Set.insert` v) $ q' >< fromList (map (,d + 1) (filter (`notElem` v) (neighbors g i)))
  Seq.EmptyL -> error "empty queue"

We have our grid, our visited set, and our upcoming queue. Each iteration, we look at the first item in our queue. If it's already visited, we ditch it and continue with the rest of the queue. If it's the goal, we return its distance. If it's any other node, we add it to our visited set, add its neighbors (with +1 distance) to our queue, and recurse.

Is that really Dijkstra's?

Now wait a minute, we aren't even using a priority queue here! Is this Dijkstra's, or is it just a breadth-first search? To that I have two things to say:

1. Every 'edge' in our grid has a weight of 1, so this is equivalent to using a priority queue in this particular scenario.
2. We could use a priority queue if we want to, I was just being lazy.

The Nitty Gritty of Goals and Neighbors

In the above code, goal is a helper function that finds the location of the 'E' in our grid. I wrote a similar helper for 'S':

findCoord :: Ix a => Char -> Array a Char -> a
findCoord c = fst . head . filter (\(_, c') -> c == c') . assocs

start :: Ix a => Array a Char -> a
start = findCoord 'S'

goal :: Ix a => Array a Char -> a
goal = findCoord 'E'

Neighbors finds the indices to the north, south, east, and west, making sure that they remain in the grid and at an accessible elevation:

elev :: Char -> Int
elev 'S' = elev 'a'
elev 'E' = elev 'z'
elev c = fromEnum c - fromEnum 'a'

neighbors :: Array (Int, Int) Char -> (Int, Int) -> [(Int, Int)]
neighbors g i@(x, y) = do
  i' <- [(x, y + 1), (x, y - 1), (x + 1, y), (x - 1, y)]
  guard $ inRange (bounds g) i'
  guard $ elev (g ! i') <= elev (g ! i) + 1
  return i'

Part 1 then kicks off go with an empty visited set and our start node.

part1 :: Array (Int, Int) Char -> Int
part1 g = go g Set.empty $ fromList [(start g, 0)]

Part 2

In Part 2, we are looking for the shortest path from any 'a' to 'E'. There are two ways we could do this. First, we could store all of our 'a' locations as our initial set and run the code again. Perhaps more cleanly, though, we can reverse our search. We'll start at 'E' and look backwards until land on any 'a'. We'll need a new function for downhill neighbors:

downhill :: Array (Int, Int) Char -> (Int, Int) -> [(Int, Int)]
downhill g i@(x, y) = do
  i' <- [(x, y + 1), (x, y - 1), (x + 1, y), (x - 1, y)]
  guard $ inRange (bounds g) i'
  guard $ elev (g ! i') >= elev (g ! i) - 1
  return i'

We can abstract out our neighbors and goal functions, to reuse the logic from Part 1:

go :: ((Int, Int) -> Bool) -> ((Int, Int) -> [(Int, Int)]) -> Array (Int, Int) Char -> Set (Int, Int) -> Seq ((Int, Int), Int) -> Int
go isGoal n g v q = case Seq.viewl q of
  (i, d) :< q' ->
    if i `elem` v
      then go isGoal n g v q'
      else
        if isGoal i
          then d
          else go isGoal n g (i `Set.insert` v) $ q' >< fromList (map (,d + 1) (filter (`notElem` v) (n i)))
  Seq.EmptyL -> error "empty queue"

part1 :: Array (Int, Int) Char -> Int
part1 g = go (== goal g) (neighbors g) g Set.empty $ fromList [(start g, 0)]

part2 :: Array (Int, Int) Char -> Int
part2 g = go ((== 0) . elev . (g !)) (downhill g) g Set.empty $ fromList [(goal g, 0)]

Full Code

There are aspects of this implementation that are not very efficient. Typically, I believe 'go isGoal neighbors' is bound once, so that the function isn't evaluated fresh every single iteration. Check out the aStar package for more professional examples. I'll likely use that on future days as needed.

{-# LANGUAGE TupleSections #-}

module AOC2022.Day12 (spec) where

import Control.Monad (guard)
import Data.Array
  ( Array,
    Ix (inRange),
    assocs,
    bounds,
    listArray,
    (!),
  )
import Data.Sequence (Seq, ViewL ((:<)), fromList, (><))
import qualified Data.Sequence as Seq
import Data.Set (Set)
import qualified Data.Set as Set
import Input (readDay)
import Test.Hspec (describe, hspec, it, shouldBe)

input :: IO (Array (Int, Int) Char)
input = listArray ((-20, 0), (20, 160)) . filter (/= '\n') <$> readDay 2022 12

spec :: IO ()
spec = hspec $ do
  describe "Day 12" $ do
    describe "Part 1" $ do
      it "runs on custom input" $ do
        myInput <- input
        part1 myInput `shouldBe` 0 -- redacted
    describe "Part 2" $ do
      it "runs on custom input" $ do
        myInput <- input
        part2 myInput `shouldBe` 0 -- redacted

findCoord :: Ix a => Char -> Array a Char -> a
findCoord c = fst . head . filter (\(_, c') -> c == c') . assocs

start :: Ix a => Array a Char -> a
start = findCoord 'S'

goal :: Ix a => Array a Char -> a
goal = findCoord 'E'

elev :: Char -> Int
elev 'S' = elev 'a'
elev 'E' = elev 'z'
elev c = fromEnum c - fromEnum 'a'

neighbors :: Array (Int, Int) Char -> (Int, Int) -> [(Int, Int)]
neighbors g i@(x, y) = do
  i' <- [(x, y + 1), (x, y - 1), (x + 1, y), (x - 1, y)]
  guard $ inRange (bounds g) i'
  guard $ elev (g ! i') <= elev (g ! i) + 1
  return i'

go :: ((Int, Int) -> Bool) -> ((Int, Int) -> [(Int, Int)]) -> Array (Int, Int) Char -> Set (Int, Int) -> Seq ((Int, Int), Int) -> Int
go isGoal n g v q = case Seq.viewl q of
  (i, d) :< q' ->
    if i `elem` v
      then go isGoal n g v q'
      else
        if isGoal i
          then d
          else go isGoal n g (i `Set.insert` v) $ q' >< fromList (map (,d + 1) (filter (`notElem` v) (n i)))
  Seq.EmptyL -> error "empty queue"

part1 :: Array (Int, Int) Char -> Int
part1 g = go (== goal g) (neighbors g) g Set.empty $ fromList [(start g, 0)]

downhill :: Array (Int, Int) Char -> (Int, Int) -> [(Int, Int)]
downhill g i@(x, y) = do
  i' <- [(x, y + 1), (x, y - 1), (x + 1, y), (x - 1, y)]
  guard $ inRange (bounds g) i'
  guard $ elev (g ! i') >= elev (g ! i) - 1
  return i'

part2 :: Array (Int, Int) Char -> Int
part2 g = go ((== 0) . elev . (g !)) (downhill g) g Set.empty $ fromList [(goal g, 0)]

Advent of Code 2022 Series

This post is part of a series describing my Haskell solutions to Advent of Code 2022.

Next: Day 13: Distress Signal Previous: Day 11: Monkey in the Middle