random undirected graphs

This little program generates random, undirected graphs without loops or isolated vertices (though the graph is not necessarily connected).

I have found it useful to generate random inputs for testing graph algorithms.

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)