2048 in Haskell

game.hs

import Data.List
import System.Random

import System.Environment
import Control.Parallel.Strategies

-- run with "./game TREEDEPTH" and it outputs a game tree of a specific depth
-- see below for more specific functions
main = do
  [depthString] <- getArgs
  let depth = read depthString :: Int
  print $ startTree depth

type Field = Maybe Int
type Row = [Field]
type Grid = [Row]

emptyGrid = replicate 4 $ replicate 4 Nothing

type Score = Int

data Game = Game Grid Score StdGen | GameOver Grid Score StdGen | GameWon Grid Score StdGen deriving (Show)

-- game tree

-- InsertNode: Game state after inserting a new value
-- MoveNode: Game state after moving the privious game state to Direction
data Node = InsertNode Grid Score [Node] | MoveNode Grid Score Direction [Node] deriving (Show)
instance NFData Node

-- use this to generate a game tree of a specific depth
startTree :: Int -> Node
startTree depth = InsertNode emptyGrid 0 $ ((map converter $ concat $ ((map possibleInserts $ possibleInserts emptyGrid) `using` parList rdeepseq)) `using` parList rdeepseq)
                  where converter g = InsertNode g 0 (moveTree depth g 0)

moveTree 0 _ _ = []
moveTree depth grid score = (map converter $ possibleMoves (grid, score)) `using` parList rdeepseq
                            where converter (d, (g, s)) = MoveNode g s d (insertTree (depth -1) g s)

insertTree 0 _ _ = []
insertTree depth grid score = (map converter $ possibleInserts grid) `using` parList rdeepseq
                              where converter g = InsertNode g score (moveTree (depth - 1) g score)

-- possibility functions

possibleMoves :: (Grid, Score) -> [(Direction, (Grid, Score))]
possibleMoves state = filter (\(_, s) -> s /= state) [(DLeft, moveLeft state), (DRight, moveRight state), (DUp, moveUp state), (DDown, moveDown state)]

possibleInserts :: Grid -> [Grid]
possibleInserts g =
  possibleInsertsOf (Just 2) [] [] g ++ possibleInsertsOf (Just 4) [] [] g
  where possibleInsertsOf :: Field -> Grid -> Row -> Grid -> [Grid]
        possibleInsertsOf v brs bxs [] = []
        possibleInsertsOf v brs bxs ([]:rs) = possibleInsertsOf v (brs ++ [bxs]) [] rs
        possibleInsertsOf v brs bxs ((x@(Just _):xs):rs) = possibleInsertsOf v brs (bxs ++ [x]) (xs:rs)
        possibleInsertsOf v brs bxs ((x@Nothing :xs):rs) = (brs ++ (bxs ++ v:xs):rs):(possibleInsertsOf v brs (bxs ++ [x]) (xs:rs))


-- game interface

startGame :: StdGen -> Game
startGame rdmGen = Game g' 0 rdmGen'
                   where (g', rdmGen') = insertAtRandom $ insertAtRandom (emptyGrid, rdmGen)

makeMove :: Game -> Direction -> Game
makeMove (Game g score rdmGen) d =
  case hasWon of
    True -> GameWon g' score' rdmGen
    _    -> case gameOver of
      True -> GameOver g'' score' rdmGen'
      _    -> Game g'' score' rdmGen'
  where (g', score') = functionForDirection d $ (g, score)
        (g'', rdmGen') = insertAtRandom (g', rdmGen)
        gameOver = allTheSame [moveLeft (g'', 0), moveRight (g'', 0), moveUp (g'', 0), moveDown (g'', 0)]
        hasWon = guFold (\b x -> if x >= 2048 then True else b) False g'

        allTheSame xs = and $ map (== head xs) (tail xs)
        
-- end game interface

data Direction = DLeft | DRight | DUp | DDown deriving (Show)
functionForDirection DLeft = moveLeft
functionForDirection DRight = moveRight
functionForDirection DUp = moveUp
functionForDirection DDown = moveDown

data MovingField = Field Int | MergedField Int

moveLeft :: (Grid, Score) -> (Grid, Score)
moveLeft (g, score) =
  (map filler $ gMap converter mergedGrid, score')
  where score' = gFold sumMerged 0 mergedGrid + score
        mergedGrid = map (reverse . foldl merger []) g -- reverse and
                     -- foldl instead of foldr to merge field on the
                     -- left first

        sumMerged sum (MergedField x) = sum + x
        sumMerged sum _ = sum
        
        merger (Field x:xs) (Just y) | x == y = MergedField (x * 2):xs
        merger xs (Just y) = Field y:xs
        merger xs _ = xs
        
        converter (Field x) = Just x
        converter (MergedField x) = Just x
        
        filler r = r ++ replicate (4 - length r) Nothing

moveRight (g, score) =
  (map reverse g', score')
  where (g', score') = moveLeft (map reverse g, score)
moveUp (g, score) =
  (transpose g', score')
  where (g', score') = moveLeft (transpose g, score)
moveDown (g, score) =
  (transpose $ map reverse g', score')
  where (g', score') = moveLeft (map reverse $ transpose g, score)

insertAtRandom :: (Grid, StdGen) -> (Grid, StdGen)
insertAtRandom (g, gen) = (ng, gen'')
  where (nth, gen') = randomR (0, countEmpty g - 1) gen
        (numberGen, gen'') = randomR (0,9) gen'
        number = case numberGen :: Int  of
          0 -> 4
          _ -> 2
        f 0 = (-1, Just number)
        f toPass = (toPass - 1, Nothing)
        (_, ng) = geMapAccum f nth g
        

-- general grid functions

-- Fold over every field.
gFold :: (b -> a -> b) -> b -> [[a]] -> b
gFold f init g = foldl (foldl f) init g

-- Fold over every used field.
guFold :: (acc -> Int -> acc) -> acc -> Grid -> acc
guFold f init g =
  gFold fu init g
  where fu acc (Just x) = f acc x
        fu acc Nothing  = acc

-- Apply function to every element in 2-dimensional list.
gMap :: (a -> b) -> [[a]] -> [[b]]
gMap _ [] = []
gMap f (x:xs) = map f x:gMap f xs

-- Maps f over every empty field, with accumulator.
geMapAccum :: (acc -> (acc, Field)) -> acc -> Grid -> (acc, Grid)
geMapAccum _ acc [] = (acc, [])
geMapAccum f acc (r:rs) = (acc'', nr:nrs)
  where (acc', nr) = mapAccumL mf acc r
        (acc'', nrs) = geMapAccum f acc' rs
        mf acc Nothing = f acc
        mf acc field = (acc, field)

countUsed :: Grid -> Int
countUsed g = guFold (\used _ -> used + 1) 0 g

countEmpty :: Grid -> Int
countEmpty g = 4 * 4 - countUsed g


-- other grid functions

insertAtPosition :: (Int, Int) -> Int -> Grid -> Grid
insertAtPosition (0, y) i (row:rows) =
  insertAtIndex y i row:rows
  where insertAtIndex y i (field:fields) = case y of
          0 -> (Just i):fields
          _ -> field:insertAtIndex (y-1) i fields
insertAtPosition (x, y) i (r:rs) = r:insertAtPosition (x-1, y) i rs


-- example grids

aGrid :: Grid
aGrid = [[Just 2, Nothing, Just 2, Just 2],
         [Just 2, Just 8, Nothing, Just 8],
         [Just 2, Just 4, Just 2, Just 4],
         [Nothing, Just 4, Nothing, Nothing]]

-- Move Right to win.
winGrid :: Grid
winGrid = [[Just 2, Just 4, Just 8, Just 2],
           [Just 16, Just 32, Just 64, Just 128],
           [Just 64, Just 512, Just 1024, Just 1024],
           [Just 32, Just 4, Just 2, Just 4]]

-- Move Right to loose.
looseGrid :: Grid
looseGrid = [[Just 2, Just 4, Just 8, Just 2],
             [Just 16, Just 32, Just 64, Just 128],
             [Just 256, Just 512, Just 8, Just 32],
             [Just 16, Just 8, Just 2, Just 2]]

Just trying around with 2048 in Haskell, you can play the game with startGame rdmGen and makeMove game or create a game tree with startTree depth (it doesn't work very well because there are just way too many possibilities, but try it out with depth = 2 for example).