5
\$\begingroup\$

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

Link to original thread: Poor AI for 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
import Control.Monad

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
\$\endgroup\$
4
\$\begingroup\$

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.

Change your representation

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.

\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.