# Revised: AI for 2048 in Haskell

This is a revised version of an AI for the game 2048, written in Haskell.

I think this version is a lot cleaner, thanks to the tips from Benesh.

I would like to know if I'm following best practice guidelines and especially if I made the right choices performance-wise.

I think the program is already a bit slow, and it will become a lot slower if start implementing the randomized aspects of the game.

{--

Plays and solves the game 2048

In this implementation the randomized aspects of the game have been removed.

--}
import Data.Time
import Data.List
import Data.Ord
import Data.Maybe

emptyGrid :: [Int]
emptyGrid = [ 0 | _ <- [0..15] ]

-- Display the 16-length list as the 4 by 4 grid it represents
gridToString :: [Int] -> String
gridToString []         = ""
gridToString xs         = show (take 4 xs) ++ "\n" ++ gridToString (drop 4 xs)

printGrid :: [Int] -> IO()
printGrid xs            = putStrLn $gridToString xs -- Skip n empty tiles before inserting addTile :: Int -> [Int] -> [Int] addTile 0 (0:grid) = 2 : grid addTile _ [] = [] addTile n (0:grid) = (0 : addTile (n-1) grid) addTile n (cell:grid) = cell : addTile n grid -- For one row of the grid, push the non-empty tiles together -- e.g. [0,2,0,2] becomes [2,2,0,0] moveRow :: [Int] -> [Int] moveRow [] = [] moveRow (0:xs) = moveRow xs ++ [0] moveRow (x:xs) = x : moveRow xs -- For one row of the grid, do the merge (cells of same value merge) -- e.g. [2,2,4,4] becomes [4,8,0,0] -- [2,4,2,2] becomes [2,4,4,0] mergeRow :: [Int] -> [Int] mergeRow [] = [] mergeRow (a:[]) = [a] mergeRow (a:b:xs) | a == b = (a + b) : (mergeRow xs) ++ [0] | otherwise = a : mergeRow (b:xs) -- Rotate the grid to be able to do vertical moving/merging -- e.g. [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15] -- becomes [0,4,8,12,1,5,9,13,2,6,10,14,3,7,11,15] rotate :: [Int] -> [Int] rotate grid = [ grid !! (a + 4 * b) | a <- [0..3], b <- [0..3] ] data Move = MoveLeft | MoveRight | MoveUp | MoveDown deriving (Show) allMoves :: [Move] allMoves = [MoveLeft, MoveRight, MoveUp, MoveDown] -- Use the definitions above to do the moves doMove :: Move -> [Int] -> [Int] doMove _ [] = [] doMove MoveLeft grid = mergeRow (moveRow (take 4 grid)) ++ doMove MoveLeft (drop 4 grid) doMove MoveRight grid = reverse (doMove MoveLeft (reverse grid)) doMove MoveUp grid = rotate (doMove MoveLeft (rotate grid)) doMove MoveDown grid = reverse (doMove MoveUp (reverse grid)) -- Take a turn, i.e. make a move and add a tile -- Return Nothing if the move is not legal takeTurn :: Move -> [Int] -> Maybe [Int] takeTurn move grid | movedGrid == grid = Nothing | otherwise = Just$ addTile 0 movedGrid
where movedGrid = doMove move grid

-- Return the best move
-- Will throw an error if there are no valid moves
bestMove :: Int -> [Int] -> Move
bestMove depth grid     = snd bestValueMove
where
valueMoves      = [ (value, move) |
move    <- allMoves,
newGrid <- [ takeTurn move grid ],
value   <- [ gridValue depth (fromJust newGrid) ],
newGrid /= Nothing ]
bestValueMove   = maximumBy (comparing fst) valueMoves

-- <<< I decided not to return Nothing on a dead end, because then we can no longer
-- distinguish dead ends at different depths from eachother. >>>
--
-- Return the value of the grid,
-- + 1 for each depth traversed
-- -100 if a Game Over position is reached
gridValue :: Int -> [Int] -> Int
gridValue depth grid
| depth == 0        = length $filter (==0) grid | values == [] = -100 | otherwise = maximum values where values = [ value | move <- allMoves, newGrid <- [ takeTurn move grid ], value <- [ gridValue (depth-1) (fromJust newGrid) + 1], newGrid /= Nothing ] gameOver :: [Int] -> Bool gameOver grid = all (==Nothing) ([ takeTurn move grid | move <- allMoves ]) -- Take turns and prints the result of each move to the console until no more moves are possible -- n counts the moves -- Should normally be called with n=0 takeTurns :: Bool -> Int -> Int -> [Int] -> IO() takeTurns isVerbose depth n grid = do when (isVerbose || isGameOver)$ putStrLn $gridToString grid ++ "\n# " ++ (show n) when (isVerbose && not isGameOver)$ putStrLn $(show move) when (not isGameOver)$ takeTurns isVerbose depth (n+1) newGrid
where
isGameOver  = gameOver grid
move        = bestMove depth grid
newGrid     = fromJust $takeTurn move grid -- Solves at depth and only prints # of moves and final grid solveSilent :: Int -> IO() solveSilent depth = takeTurns False depth 0 (addTile 0 emptyGrid) -- Solves at depth and prints all boards and moves solve :: Int -> IO() solve depth = takeTurns True depth 0 (addTile 0 emptyGrid) -- Solve and time the solver for multiple depth settings from start to end solveDepths :: Int -> Int -> IO() solveDepths start end | start <= end = do startTime <- getCurrentTime solveSilent start stopTime <- getCurrentTime putStrLn$ "Depth " ++ (show start) ++ " done in " ++ (show \$ diffUTCTime stopTime startTime)
solveDepths (start+1) end
| otherwise = putStrLn "-"

main = solveDepths 1 3


I am unfortunately no performance guru, but will take a stab at this as I repeatedly had to make programs faster, and there are no answer yet.

A nitpick : I would have used a type synonym for Grid and Row :

type Grid = [Int]
type Row = [Int]
addTile :: Int -> Grid -> Grid
moveRow :: Row -> Row


This doesn't help too much here, but might make things more obvious in the long run.

Now, considering performance, the choice of a list of integer will make your program hard to optimize. Functions such as this will be really slow :

rotate grid = [ grid !! (a + 4 * b) | a <- [0..3], b <- [0..3] ]


As lists are linked lists, and indexing will traverse all previous elements. Profiling shows that this is the most time consuming function.

I would suggest one or a combination of the following solutions.

# Using the ST monad

The ST monad is a strict state monad. It is pretty useful for encapsulating value-mutating algorithms in referentially transparent functions. Basically, you would write algorithms the way you would in C, and the resulting code should be quite efficient. The STArray type might be a good candidate.

# Using a library known for its performance

A library such as repa or vector, both are known to be able to generate crazy fast code when the right rewrite rules fire. repa is probably overkill, and hard to understand. You can alter vectors in the ST monad too.

The doMove function takes most of the time. It has an implementation for a single case (MoveLeft), and all other cases rotate the board, run a MoveLeft, and rotate it back. It might be possible to either have specialized implementations for each case, or, perhaps better, to use function composition / modification to skip the rotate / rotate back operations.