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.

	import Data.List (nub, unfoldr)
	import Control.Arrow ((***))
	import Control.Monad (join, replicateM)
	import Graphics.UI.SDL as SDL
	import Graphics.UI.SDL.Primitives (line)
	import System.Random.Shuffle (shuffle')
	import System.Random.Mersenne.Pure64 (newPureMT, randomInt)
	[xres, yres, unit] = map (1 *) [512, 512, 5]
	main = withInit [InitVideo] $ do
	window <- setVideoMode xres yres 32 [NoFrame]
	enableEvent SDLMouseMotion False
	setCaption "Random Graphs" "Random Graphs"
	render window =<< genGraph
	run
	run = do
	delay 128
	e <- pollEvent
	case e of
	KeyUp (Keysym SDLK_ESCAPE _ _) -> return ()
	_ -> run
	render w ls = do
	s <- createRGBSurface [SWSurface] unit unit 32 0 0 0 0
	fillRect s Nothing $ Pixel 0xFFFFFF
	fillRect w (Just $ Rect 0 0 xres yres) (Pixel 0)
	mapM_ (draw w s) ls
	SDL.flip w
	draw w s ((a,b), (x,y)) = do
	blitSurface s Nothing w $ rect (a,b)
	blitSurface s Nothing w $ rect (x,y)
	line w a' b' x' y' $ Pixel 0xFF0000FF
	where
	rect (x,y) = Just $ Rect x y unit unit
	[a', b', x', y'] = map ((+2) . fromIntegral) [a,b,x,y]
	genGraph = do
	gs <- replicateM 2 newPureMT
	ps <- return . nub . take 15 $ rands gs
	qs <- permute ps
	return $ filter p $ zip ps qs
	where
	permute xs = fmap (shuffle' xs $ length xs) newPureMT
	p ((a,b), (x,y)) = (a,b) /= (y,x) && (a,b) /= (x,y)
	rands [g, g'] = map (f . h) $ zip xs ys
	where
	xs = map ((8+) . (`mod` x)) $ unfoldr (Just . randomInt) g
	ys = map ((8+) . (`mod` y)) $ unfoldr (Just . randomInt) g'
	(x,y) = (xres - 16, yres - 16)
	(f,h) = (join (***) (* unit), join (***) (`div` unit))

view raw random-graphs.hs hosted with ❤ by GitHub