a-star.hs

import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Set as Set
import qualified Data.List.NonEmpty as NE
import Data.List.NonEmpty (NonEmpty (..), (<|))
​
{- |
   I use `Map.Map` as a priority queue, by popping element
   with a minimal key using `Map.minView`.
-}

aStar
  :: (Num d, Ord d, Ord a)
  => (a -> d)       -- distance estimation
  -> (a -> [a])     -- neighbours retrieval
  -> (a -> a -> d)  -- distance between 2 points
  -> d              -- distance from end we should reach
  -> a              -- starting point
  -> Maybe (NE.NonEmpty a)
aStar estimate neighbors dist epsilon start = do
    NE.reverse <$> go Set.empty initialQueue
  where
    initialQueue = Map.singleton (cost start 0) (start :| [], 0)
​
    cost point traversed = estimate point + traversed
​
    go visited queue = do
      ((path @ (point :| _), distance), queue') <- Map.minView queue
​
      if estimate point <= epsilon
      then do
        return path
​
      else do
        let near  = filter (`Set.notMember` visited) (neighbors point)
            batch = flip map near $ \\point' ->
              let distance' = distance + dist point' point
              in (cost point' distance', (point' <| path, distance'))
​
        go (Set.insert point visited) (Map.fromList batch <> queue')