nibbles

Remember this game? It came bundled with QBasic, back in the good old MS-DOS days...

The game's many subsequent clones often called it Snake instead.

	import Graphics.UI.SDL as SDL hiding (init)
	import System.Random.Mersenne.Pure64 (newPureMT, randomInt)
	import Control.Monad (join, replicateM)
	import Control.Arrow ((***))
	import Data.List (unfoldr)
	[xres, yres, unit] = map (12 *) [90, 50, 1]
	main = withInit [InitVideo] $ do
	window <- setVideoMode xres yres 32 []
	seeds <- replicateM 2 newPureMT
	enableEvent SDLMouseMotion False
	setCaption "Nibbles" "Nibbles"
	run window 8 (rands seeds) snake right
	where
	snake = [unscale (xres `div` 2, yres `div` 2)]
	run w n (r:rs) s@(p:ps) d@(x,y) = if dead s then end else do
	delay 48
	render w r s
	e <- pollEvent
	case e of
	KeyUp (Keysym SDLK_ESCAPE _ _) -> end
	KeyUp (Keysym SDLK_UP _ _) -> go $ d == down ? (d, up)
	KeyUp (Keysym SDLK_RIGHT _ _) -> go $ d == left ? (d, right)
	KeyUp (Keysym SDLK_DOWN _ _) -> go $ d == up ? (d, down)
	KeyUp (Keysym SDLK_LEFT _ _) -> go $ d == right ? (d, left)
	_ -> go d
	where
	end = putStrLn $ "Score: " ++ show (length s - 9)
	go = run w n' rs' $ f p : (n > 0 ? (s, init s))
	rs' = r == scale p ? (rs, r:rs)
	n' = r == scale p ? (7, n - 1)
	f = (x+) *** (+y)
	render w r ps = do
	s <- createRGBSurface [SWSurface] unit unit 32 0 0 0 0
	fillRect w (Just $ Rect 0 0 xres yres) (Pixel 0)
	mapM_ (draw s 0xFFFFFF . scale) ps
	draw s 0x00FF00 r
	SDL.flip w
	where
	rect (x,y) = Just $ Rect x y unit unit
	draw s c p = do fillRect s Nothing $ Pixel c
	blitSurface s Nothing w $ rect p
	dead (p:ps) = p `elem` ps || exterior (scale p)
	where
	exterior (x,y) = or [x < 0, y < 0, x >= xres, y >= yres]
	rands [g, g'] = map (scale . unscale) $ zip xs ys
	where
	xs = map (`mod` xres) $ unfoldr (Just . randomInt) g
	ys = map (`mod` yres) $ unfoldr (Just . randomInt) g'
	scale = join (***) (* unit)
	unscale = join (***) (`div` unit)
	[up, right, down, left] = zip [0, 1, 0, -1] [-1, 0, 1, 0]
	p ? (a,b) = if p then a else b; infix 2 ?

view raw nibbles_aka_snake.hs hosted with ❤ by GitHub