Monday, November 2, 2015

a lava lamp

This 'lava lamp' is actually a simple cyclic cellular automaton. The rule is courtesy of Jason Rampe.
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