a lava lamp

This 'lava lamp' is actually a simple cyclic cellular automaton; the CA rule is courtesy of Jason Rampe. In keeping with the spirit of Haskell, I chose to implement it with a hashmap of points rather than an array. Needless to say, that's not practical; but this is just a demonstration.

	import Control.Arrow ((***))
	import Control.Monad (join, liftM2)
	import Data.List (unfoldr)
	import Data.Maybe (fromJust)
	import qualified Data.HashMap.Strict as M
	import Graphics.UI.SDL as SDL
	import System.Random.Mersenne.Pure64 (newPureMT, randomInt)
	(xres, yres, unit) = (160, 90, 10)
	main = withInit [InitVideo] $ do
	w <- setVideoMode (f xres) (f yres) 32 [NoFrame]
	enableEvent SDLMouseMotion False
	setCaption "Cyclic CA" "Cyclic CA"
	pause w =<< randPattern
	where
	f = (* unit)
	pause w cs = do
	delay 128
	e <- pollEvent
	case e of
	KeyUp (Keysym SDLK_ESCAPE _ _) -> return ()
	KeyUp (Keysym SDLK_SPACE _ _) -> run w cs
	_ -> pause w cs
	run w cs = do
	drawCells w cs
	SDL.flip w
	e <- pollEvent
	case e of
	KeyUp (Keysym SDLK_ESCAPE _ _) -> return ()
	KeyUp (Keysym SDLK_SPACE _ _) -> pause w cs
	_ -> run w cs'
	where
	cs' = M.mapWithKey (next cs) cs
	drawCells w cs = do
	s <- createRGBSurface [] unit unit 32 0 0 0 0
	mapM_ (draw s) $ M.toList cs
	where
	rgb n = [0xFF0000, 0xAA0000, 0x770000] !! n
	rect (x,y) = Just $ Rect x y unit unit
	scale = rect . join (***) (* unit)
	draw s (p,n) = do fillRect s Nothing $ Pixel $ rgb n
	blitSurface s Nothing w $ scale p
	randPattern = fmap (M.fromList . zip ps) ns
	where
	g = map (`mod` 3) . unfoldr (Just . randomInt)
	ns = (return . g) =<< newPureMT
	ps = liftM2 (,) [0.. xres - 1] [0.. yres - 1]
	next cs p n = if m >= 10 then n' else n
	where
	m = length $ filter (== n') area
	area = map (fromJust . (`M.lookup` cs)) $ moore p
	n' = (n + 1) `mod` 3
	moore (x,y) = filter p ps
	where
	ps = liftM2 (,) [x-2.. x+2] [y-2.. y+2]
	p (x,y) = x >= 0 && x < xres && y >= 0 && y < yres

view raw lava-lamp-automaton.hs hosted with ❤ by GitHub