Wednesday, August 19, 2015

random undirected graphs

This little program generates random, undirected graphs without loops or isolated vertices - though the graph is not necessarily connected.
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))

No comments:

Post a Comment