2048 game in Haskell

2048.hs

{-# LANGUAGE ForeignFunctionInterface #-}
import System.Console.ANSI (clearScreen)
import Data.Char
import Foreign.C.Types
import Prelude hiding (Left, Right)
import GHC.Exts (groupWith, sortWith)
import Control.Arrow
import System.Random
import System.IO
import Data.Hashable
import Data.Maybe
import Data.List
import System.Process

getHiddenChar = fmap (chr.fromEnum) c_getch
foreign import ccall unsafe "conio.h getch"
	c_getch :: IO CInt

(boardW, boardH) = (boardSize, boardSize) where boardSize = 4

data Direction = Right | Top | Left | Bottom deriving (Eq, Show, Enum)
data Hole = Hole {getPos :: (Int, Int), getValue :: Int} deriving (Eq, Show)
newtype Board = Board {getHoles :: [Hole]}

instance Hashable Hole where hashWithSalt s (Hole p v) = hashWithSalt s (p, v)
instance Hashable Board where hashWithSalt s (Board hs) = hashWithSalt s hs

instance Show Board where
	show (Board hs) = (++ "\n") . intercalate "\n\n" . map (intercalate "\t") $ ls where
		ls = do
			y <- [boardH-1,boardH-2..0]
			return $ do
				x <- [0..boardW-1]
				return $ case find ((== (x, y)) . getPos) hs of
					Nothing -> "_"
					Just h -> show $ getValue h

sink :: (Eq a, Num a) => [a] -> [a]
sink [] = []
sink (x : []) = (x : [])
sink (x : y : xs)
	| x == y = (x + y) : sink xs
	| otherwise = x : sink (y : xs)

toOneLine :: Direction -> [Hole] -> (Int, [Int])
fromOneLine :: Direction -> (Int, [Int]) -> [Hole]

varOnX dir = even (fromEnum dir)
isDesc dir = fromEnum dir >= 2
nthOnDirection i dir = if isDesc dir then i else dirLimit - i where
	dirLimit = (if varOnX dir then boardW else boardH) - 1

toOneLine dir = (f' . getPos . head &&& map getValue) . (sortWith (sig . f . getPos)) where
	(f, f') = if varOnX dir then (fst, snd) else (snd, fst)
	sig = if isDesc dir then id else negate

fromOneLine dir (cv, vs) = do
	(v, i) <- zip vs [0..]
	let vv = i `nthOnDirection` dir
	return $ Hole (if varOnX dir then (vv, cv) else (cv, vv)) v

sinkBoard :: Direction -> Board -> Board
sinkBoard dir = Board . concat . map sinkOneLine . groupWith (field . getPos) . getHoles 
	where
		sinkOneLine = fromOneLine dir . (id *** sink) . toOneLine dir
		field = if dir == Left || dir == Right then snd else fst

zeroBoard = Board []

randomHoles :: Int -> [Hole]
randomHoles seed = map f (randoms (mkStdGen seed)) where
	f r = Hole (x, y) 2 where
		xy = r `mod` (boardW * boardH)
		(x, y) = ((uncurry mod) &&& (uncurry div)) (xy, boardW)

incBoard :: Board -> Maybe Board
incBoard (Board hs) | length hs >= boardW * boardH = Nothing
incBoard (Board hs) = Just (Board (h : hs)) where
	ps = map getPos hs
	seed = hash (Board hs)
	h = fromMaybe undefined $ find (not . (`elem` ps) . getPos) $ randomHoles seed

incBoard' = fromMaybe zeroBoard . incBoard

main = do
	hSetBuffering stdin NoBuffering
	let loop board = do
		c <- getHiddenChar
		let dir = toEnum $ (`mod` 4) $ fromMaybe (-1) $ findIndex (== c) "dwaslkhj" :: Direction
		let board' = incBoard' $ sinkBoard dir $ board
		clearScreen
		print board'
		putStr "\n\n\n"
		loop board'
	print (incBoard' zeroBoard)
	loop (incBoard' zeroBoard)