generalizing langton's ant

Christopher Langton's ant can be generalized by adding states to the ant, producing automata known as turmites. Shown here is the behavior of one interesting two-state turmite, started on an empty plane. Click the thumbnail to see more generations; you'll see that this turmite always produces a framed square with the same distinctive irregular pattern.

	import Control.Arrow ((***))
	import Control.Monad (join, void, when)
	import Data.Set (delete, empty, insert, member, toList)
	import Graphics.UI.SDL as SDL
	(xres, yres, sq) = (1600, 900, 2)
	main = withInit [InitVideo] $ do
	w <- setVideoMode xres yres 32 [NoFrame]
	enableEvent SDLMouseMotion False
	setCaption "Turmite" "Turmite"
	run w [1..] 0 p (0,1) empty
	where
	p = (xres `div` 2 `div` sq, yres `div` 2 `div` sq)
	run w (n:ns) s p v ps = do
	when (n `mod` 23 == 0) $ render w ps
	e <- pollEvent
	case e of
	KeyUp (Keysym SDLK_ESCAPE _ _) -> print n >> printout
	KeyUp (Keysym SDLK_SPACE _ _) -> pause w s p v ps
	_ -> continue
	where
	continue = go w ns s p v ps
	printout = void $ saveBMP w "output.bmp"
	pause w s p v ps = do
	delay 128
	e <- pollEvent
	case e of
	KeyUp (Keysym SDLK_ESCAPE _ _) -> return ()
	KeyUp (Keysym SDLK_SPACE _ _) -> run w [1..] s p v ps
	_ -> pause w s p v ps
	render w ps = do
	fillRect w (Just $ Rect 0 0 xres yres) $ Pixel 0
	mapM_ (draw w . join (***) (* sq)) $ toList ps
	SDL.flip w
	draw w p = f p =<< g [SWSurface] sq sq 32 0 0 0 0
	where
	rect x y = Just $ Rect x y sq sq
	g = createRGBSurface
	f (x,y) s = do fillRect s (rect 0 0) $ Pixel 0xFFFFFF
	blitSurface s (rect 0 0) w $ rect x y
	go w ns s p v ps
	| s == 0 && not b = run w ns 0 (f p $ l' v) (l' v) qs
	| s == 0 && True = run w ns 1 (f p $ r' v) (r' v) qs
	| s == 1 && not b = run w ns 0 (f p $ r' v) (r' v) rs
	| otherwise = run w ns 1 (f p $ l' v) (l' v) rs
	where
	b = member p ps
	(qs, rs) = (insert p ps, delete p ps)
	f (x, y) = (x +) *** (+ y)
	r' (0, y) = (-y, 0)
	r' (x, y) = ( y, x)
	l' (0, y) = ( y, 0)
	l' (x, y) = ( y, -x)

view raw langton_turmite.hs hosted with ❤ by GitHub