graph search

An implementation of general graph search. The search strategy is determined by the definition on line 59, cost. The expression shown below produces an A* search. If instead one substitutes cost = sum . map dist . segments, the procedure becomes a uniform-cost search. Using length finds the path with fewest nodes, and simiarly dist [last ps, goal] produces a greedy best-first algorithm.

{-# LANGUAGE PackageImports #-}

import Graphics.UI.SDL.Primitives (line, filledCircle)
import Graphics.UI.SDL as SDL
import Control.Monad (mapM_, liftM, liftM2)
import System.Random.Mersenne.Pure64 (pureMT, randomInt)
import Data.List (unfoldr, groupBy, sortBy, maximumBy)
import Data.Ord (comparing)
import Data.Function (on)
import "hashmap" Data.HashSet (fromList, toList, difference,
  intersection, empty, insert, delete, unions, member)
  
main = withInit [InitVideo] $ do
  win <- setVideoMode xres yres 32 [Fullscreen]
  enableEvent SDLMouseMotion False
  fillRect win (Just $ Rect 0 0 xres yres) (Pixel 0)
  drawGraph win
  SDL.flip win
  loop
  
loop = do
  delay 200
  e <- pollEvent
  case e of
    KeyUp (Keysym SDLK_ESCAPE _ _) -> return ()
    _                              -> loop
  
drawGraph w = do
  let route = search [[start]] empty
  drawLines w 0x0000FFFF (map toList graph)
  drawNodes w 0xFFFFFFFF nodes
  drawNodes w 0xFFFF00FF route
  drawLines w 0xFFFF00FF (segments route)
  drawNodes w 0x00FF00FF [start]
  drawNodes w 0xFF0000FF [goal]
  
drawNodes w rgb = mapM_ draw
 where
  draw [x,y] = filledCircle w x y 4 (Pixel rgb)
  
drawLines w rgb = mapM_ draw
 where
  draw [[a, b], [c, d]] = line w a b c d (Pixel rgb)
 
--------------------------------------------------------------------------
 
search frontier explored
  | null frontier = []
  | otherwise     = if state == goal then path
                      else search next (state `insert` explored)
 where
  state = last path
  path  = head frontier
  next  = tail frontier ++ actions path explored state
  
actions path explored state = sort' . map nextstep $ toList locality
 where
  sort'    = sortBy $ comparing cost
  cost ps  = dist [last ps, goal] + sum (map dist $ segments ps)
  nextstep = (path ++) . return
  locality = let s = state `delete` unions (filter (member state) graph)
              in s `difference` (s `intersection` explored)
 
graph = map fromList . concatMap nearby $ group pairs
 where
  group  = groupBy ((==) `on` head)
  nearby = takeWhile ((< 280) . dist) . sortBy (comparing dist)
  
nodes = take 64 . map cast $ zipWith pair (rand xres 0) (rand yres 1)
 where
  rand m = map (`mod` m) . unfoldr (liftM randomInt . Just) . pureMT
 
--------------------------------------------------------------------------
 
[goal, start] = maximumBy (comparing dist) pairs
 
pairs         = filter (\[a,b] -> a /= b) $ liftM2 pair nodes nodes
  
segments ps   = zipWith pair ps (tail ps)
  
dist [a,b]    = sqrt $ (x'-x)^2 + (y'-y)^2
                  where ([x,y], [x',y']) = (cast a, cast b)
  
pair a b      = [a, b]
cast [a,b]    = [fromIntegral a, fromIntegral b]
 
(xres, yres)  = (1600, 900)