Implementation of the A* algorithm for Haskell

astar.hs

import qualified Data.Set as S
import Data.Map (Map)
import qualified Data.Map as M

reconstructPath :: Ord a => Map a a -> a -> [a]
reconstructPath cameFrom end = helper end [end]
  where helper current total = case M.lookup current cameFrom of
          Just v -> helper v (v:total)
          Nothing -> total

uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e
uncurry4 f (a, b, c, d) = f a b c d

astar :: (Fractional r, Ord t, Ord r) =>
         (t -> t -> r) -> (t -> [t]) -> (t -> t -> r) -> t -> t -> Maybe [t]
astar heuristicEstimate getNeighbors dist start end = astarHelper
                                                S.empty
                                                (S.singleton start)
                                                M.empty
                                                (M.singleton start 0)
                                                (M.singleton start $ heuristicEstimate start end)
  where astarHelper closedSet openSet cameFrom gScore fScore = do
          current <- S.foldr (lowestFValue fScore) Nothing openSet
          if current==end
            then Just $ reconstructPath cameFrom end
            else
              let openSet' = S.delete current openSet in
              let closedSet' = S.insert current closedSet in
              let neighbors = filter (not . flip S.member closedSet) $ getNeighbors current in
              uncurry4 (astarHelper closedSet') $
              foldr (reduceNeighbors current)
                    (openSet', cameFrom, gScore, fScore) neighbors
        lowestFValue _      node Nothing = Just node
        lowestFValue fScore node (Just node')
          | (M.findWithDefault (1/0) node' fScore) > (M.findWithDefault (1/0) node fScore) = Just node
          | otherwise = Just node'
        reduceNeighbors current neighbor (openSet, cameFrom, gScore, fScore) =
          let tentativeGScore = (M.findWithDefault (1/0) current gScore)+dist current neighbor in
          if (S.member neighbor openSet) || tentativeGScore < (M.findWithDefault (1/0) neighbor gScore)
          then (S.insert neighbor openSet,
                M.insert neighbor current cameFrom,
                M.insert neighbor tentativeGScore gScore,
                M.insert neighbor (tentativeGScore + heuristicEstimate neighbor end) fScore)
          else (openSet, cameFrom, gScore, fScore)