2048

It's been a while without any new posts here; I've been focused on projects where JavaScript or C are more suitable than Haskell (for me, anyway). But I did dust off GHC this weekend to write this no-frills clone of Gabriele Cirulli's popular '2048' puzzle game. It didn't come out quite as concise as I had hoped - maybe I'm a bit rusty? :)

As usual with my graphical stuff, you'll need the legacy (1.2) versions of SDL to compile this. And the font path may vary; adjust it for your system.

	import Control.Monad
	import Data.List (notElem, nub, transpose, unfoldr)
	import Graphics.UI.SDL as SDL
	import Graphics.UI.SDL.TTF as TTF (init, openFont, renderTextSolid)
	import System.Random.Mersenne.Pure64 (newPureMT, randomInt)
	-------------------------------------------------------------------
	[xres, yres] = [512, 512]
	main = withInit [InitVideo] $ do
	TTF.init
	window <- setVideoMode xres yres 32 []
	seeds <- replicateM 2 newPureMT
	board <- initBoard $ randCoords seeds
	dejaVu <- openFont font 48
	enableEvent SDLMouseMotion False
	setCaption "2048" "2048"
	run window dejaVu board $ randCoords seeds
	where
	font = "/usr/share/fonts/TTF/liberation/LiberationMono-Bold.ttf"
	run w font grid (p:ps) = do
	delay 32
	when (0 `notElem` concat grid) endGame
	render w font grid
	e <- pollEvent
	case e of
	KeyUp (Keysym SDLK_ESCAPE _ _) -> endGame
	KeyUp (Keysym SDLK_UP _ _) -> go (f $ up grid) ps
	KeyUp (Keysym SDLK_RIGHT _ _) -> go (f $ right grid) ps
	KeyUp (Keysym SDLK_DOWN _ _) -> go (f $ down grid) ps
	KeyUp (Keysym SDLK_LEFT _ _) -> go (f $ left grid) ps
	_ -> go grid $ p:ps
	where
	endGame = showScore w font . sum $ map sum grid
	(go, f) = (run w font, birth $ p:ps)
	birth (p:ps) m = if zero p then set m p 2 else birth ps m
	where
	zero (i,j) = 0 == (m !! j) !! i
	render w font grid = do
	fillRect w (Just $ Rect 0 0 xres yres) bgBlue
	digits <- zipWithM txtify grid' color
	zipWithM_ (draw w) digits windowCoords
	SDL.flip w
	where
	txtify = renderTextSolid font . text
	text n = if n == 0 then " " else show n
	color = repeat $ Color 255 255 100
	grid' = concat $ transpose grid
	bgBlue = Pixel 0xFF112277
	showScore w font score = do
	fillRect w (Just $ Rect 0 0 xres yres) (Pixel 0)
	let s = "Score: " ++ show score
	txt <- renderTextSolid font s $ Color 255 255 255
	draw w txt (140 - 10 * length (show score), 220)
	SDL.flip w >> SDL.delay 3500 >> SDL.quit
	draw w s p = blitSurface s Nothing w $ rect p
	where
	rect (x,y) = Just $ Rect x y 1 1
	----------------------------------------------
	wrap = take 4 . merge . (++ repeat 0)
	where
	merge (m:n:ns)
	| m == n = 2 * m : merge ns
	| m /= n = m : merge (n:ns)
	left = map wrap . pull
	right = map (reverse . wrap . reverse) . push
	up = transpose . map wrap . transpose . raise
	down = transpose . f . transpose . lower
	where
	f = map $ reverse . wrap . reverse
	(raise, lower) = (xfx pull, xfx push)
	where
	xfx f = transpose . f . transpose
	(push, pull) = (map $ fst . f, map $ snd . f)
	where
	f ns = (blanks ++ r, r ++ blanks)
	where
	blanks = replicate (4 - l) 0
	(r, l) = (filter (> 0) ns, length r)
	----------------------------------------------
	initBoard ps = return $ set (set grid p 2) q 2
	where
	grid = replicate 4 [0,0,0,0]
	[p,q] = take 2 . nub $ take 10 ps
	randCoords [g, g'] = zip xs ys
	where
	xs = f $ unfoldr (Just . randomInt) g
	ys = f $ unfoldr (Just . randomInt) g'
	f = map (`mod` 4)
	windowCoords = liftM2 (,) ns ns
	where
	ns = [32, 160, 288, 416]
	set m (i,j) v = take j m ++ val : xs
	where
	(val, xs) = (f (m !! j) i v, drop (j+1) m)
	f xs i v = take i xs ++ (v : drop (i+1) xs)

view raw 2048.hs hosted with ❤ by GitHub