diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,6 @@ +# 0.2.0.0 + +* conditional flags: `exe` and `vty` +* can now proceed after winning the game +* version number changed from `0.1.0.3` to `0.2.0.0` due to version policy +* change `System.Game` to `Game` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,47 +2,52 @@ [![Build Status](https://travis-ci.org/Javran/h2048.svg?branch=master)](https://travis-ci.org/Javran/h2048) -a haskell implementation of Game 2048 +A haskell implementation of Game 2048. Including: +* a library for experimenting game strategies for Game 2048 +* a simple CLI that merely pretty-prints the game board +* a better CLI implemented using [vty-ui](http://hackage.haskell.org/package/vty-ui) + Based on [2048](https://github.com/gabrielecirulli/2048) # Screenshots ## Simple CLI version -![](https://github.com/Javran/h2048/releases/download/0.1.0.0/h2048-simple.jpg) +![](http://i.imgur.com/FS3tdLp.jpg) ## vty CLI version -![](https://github.com/Javran/h2048/releases/download/0.1.0.0/h2048-vty.jpg) +![](http://i.imgur.com/twNDMeq.jpg) ## Build and run ### With cabal +`h2048` is now available on [hackage](http://hackage.haskell.org/package/h2048). + If you have [Cabal](http://www.haskell.org/cabal/) installed, -you can use the following command to build this project: +you can use the following command to install this project: - cabal build + cabal update + cabal install h2048 -The executable will be located at `dist/build/h2048-simple/h2048-vty`, -to run the program: +The binaries are `h2048-simple` for simple CLI version, `h2048-vty` for CLI version +implemented using `vty-ui`. - ./dist/build/h2048-simple/h2048-vty +### Flags -Or alternatively: +If you just want the functionality of this library, you can turn off flag `exe`. +If you have trouble building the `vty` CLI version, you can try to turn off flag `vty`. - cabal run h2048-vty +An example for turning off flag `vty`: -If you have trouble building the `vty` CLI version, -you can try to turn off feature `vty` and use `h2028-simple`: + # if you are installing package from hackage: + cabal install --flag="-vty" + # or if you are building from the github repo cabal configure --flag="-vty" cabal build - # now the program should be ready - cabal run h2048-simple - # or alternatively: - ./dist/build/h2048-simple/h2048-simple ### Without cabal diff --git a/h2048.cabal b/h2048.cabal --- a/h2048.cabal +++ b/h2048.cabal @@ -2,11 +2,13 @@ -- see http://haskell.org/cabal/users-guide/ name: h2048 -version: 0.1.0.2 +version: 0.2.0.0 synopsis: a haskell implementation of Game 2048 -description: a haskell implementation of Game 2048, - based on . +description: + A haskell implementation of Game 2048, + based on . + homepage: https://github.com/Javran/h2048 license: MIT license-file: LICENSE @@ -15,7 +17,7 @@ copyright: Copyright (c) 2014 Javran Cheng category: Game build-type: Simple -extra-source-files: README.md +extra-source-files: README.md, CHANGELOG.md cabal-version: >=1.10 flag exe @@ -28,17 +30,21 @@ library hs-source-dirs: src - exposed-modules: System.Game.H2048.Core, - System.Game.H2048.Utils, - System.Game.H2048.UI.Simple, - System.Game.H2048.UI.Vty + exposed-modules: Game.H2048.Core, + Game.H2048.Utils + if flag(exe) + exposed-modules: Game.H2048.UI.Simple + if flag(exe) && flag(vty) + exposed-modules: + Game.H2048.UI.Vty + build-depends: base >= 4 && < 5, transformers >= 0 && < 1, mtl >= 2 && < 3, MonadRandom >= 0 && < 1, text >= 1 && < 2, - vty >= 4 && < 5, + vty >= 4 && < 6, vty-ui >= 1 && < 2 ghc-options: -Wall @@ -51,8 +57,7 @@ build-depends: base >= 4 && < 5, transformers >= 0 && < 1, mtl >= 2 && < 3, - MonadRandom >= 0 && < 1, - h2048 >= 0 && < 1 + MonadRandom >= 0 && < 1 if ! flag(exe) buildable: False @@ -65,12 +70,11 @@ ghc-options: -Wall build-depends: base >= 4 && < 5, text >= 1 && < 2, - vty >= 4 && < 5, + vty >= 4 && < 6, vty-ui >= 1 && < 2, transformers >= 0 && < 1, mtl >= 2 && < 3, - MonadRandom >= 0 && < 1, - h2048 >= 0 && < 1 + MonadRandom >= 0 && < 1 if ! flag(exe) || ! flag(vty) buildable: False @@ -86,7 +90,6 @@ MonadRandom >= 0 && < 1, transformers >= 0 && < 1, mtl >= 2 && < 3, - HUnit >= 1 && < 2, - h2048 >= 0 && < 1 + HUnit >= 1 && < 2 default-language: Haskell2010 diff --git a/src/Game/H2048/Core.hs b/src/Game/H2048/Core.hs new file mode 100644 --- /dev/null +++ b/src/Game/H2048/Core.hs @@ -0,0 +1,213 @@ +{-| + Module : Game.H2048.Core + Copyright : (c) 2014 Javran Cheng + License : MIT + Maintainer : Javran.C@gmail.com + Stability : experimental + Portability : POSIX + +The core game logic implementation for Game 2048. + +The routine for using this library would be: + +1. use `initGameBoard` to get a valid board to begin with. +(two new cells are inserted for you, if you want to use an empty board, +`initBoard` is a shorthand) + +2. interact with user / algorithm / etc., use `updateBoard` to update a board. + +3. use `insertNewCell` to insert a new cell randomly + +4. examine if the player wins / loses / is still alive using `gameState`. + +-} +module Game.H2048.Core + ( Board + , Line + , Dir (..) + , BoardUpdated (..) + , GameState (..) + , gameState + , compactLine + , initBoard + , initGameBoard + , updateBoard + , insertNewCell + , generateNewCell + ) +where + +import Control.Arrow +import Control.Monad +import Control.Monad.Writer +import Control.Monad.Random +import Data.List +import Data.Maybe + +import Game.H2048.Utils + +-- | represent a 4x4 board for Game 2048 +-- each element should be either zero or 2^i +-- where i >= 1. +type Board = [[Int]] + +-- | a list of 4 elements, stands for +-- one column / row in the board +type Line = [Int] + +-- | result after a successful 'updateBoard' +data BoardUpdated = BoardUpdated + { brBoard :: Board -- ^ new board + , brScore :: Int -- ^ score collected in this update + } deriving (Eq, Show) + +-- | current game state, see also 'gameState' +data GameState = Win -- ^ win, can make no step further + | WinAlive -- ^ win, and still alive + | Lose -- ^ can make no step further, no cell reaches 2048 + | Alive -- ^ playing + deriving (Enum, Eq, Show) + +-- | move direction +data Dir = DUp + | DDown + | DLeft + | DRight + deriving (Enum, Bounded, Eq, Ord, Show) + +-- | the initial board before a game started +initBoard :: Board +initBoard = (replicate 4 . replicate 4) 0 + +-- | move each non-zero element to their leftmost possible +-- position while preserving the order +compactLine :: Line -> Writer (Sum Int) Line +compactLine = runKleisli + -- remove zeros + ( filter (/=0) + -- do merge and collect score + ^>> Kleisli merge + -- restore zeros, on the "fst" part + >>^ take 4 . (++ repeat 0)) + + where + merge :: [Int] -> Writer (Sum Int) [Int] + merge (x:y:xs) = + if x == y + -- only place where score are collected. + then do + -- try to merge first two elements, + -- and process rest of it. + xs' <- merge xs + tell . Sum $ x + y + return $ (x+y) : xs' + else do + -- just skip the first one, + -- and process rest of it. + xs' <- merge (y:xs) + return $ x : xs' + merge r = return r + +-- | update the board taking a direction, +-- a 'BoardUpdated' is returned on success, +-- if this update does nothing, that means a failure (Nothing) +updateBoard :: Dir -> Board -> Maybe BoardUpdated +updateBoard d board = if board /= board' + then Just $ BoardUpdated board' (getSum score) + else Nothing + where + board' :: Board + -- transform boards so that + -- we only focus on "gravitize to the left". + -- and convert back after the gravitization is done. + (board',score) = runWriter $ + runKleisli + -- transform to a "gravitize to the left" problem + ( rTransL + -- gravitize to the left + ^>> Kleisli (mapM compactLine) + -- transform back + >>^ rTransR) board + + -- rTrans for "a list of reversible transformations, that will be performed in order" + rTrans :: [Board -> Board] + rTrans = + case d of + -- the problem itself is "gravitize to the left" + DLeft -> [] + -- we use a mirror + DRight -> [map reverse] + -- diagonal mirror + DUp -> [transpose] + -- same as DUp case + DRight case + DDown -> [transpose, map reverse] + + -- how we convert it "into" and "back" + rTransL = foldl (flip (.)) id rTrans + rTransR = foldr (.) id rTrans + +-- | find blank cells in a board, +-- return coordinates for each blank cell +blankCells :: Board -> [(Int, Int)] +blankCells b = map (\(row, (col, _)) -> (row,col)) blankCells' + where + blankCells' = filter ((== 0) . snd . snd) linearBoard + -- flatten to make it ready for filter + linearBoard = concat $ zipWith tagRow [0..] colTagged + + -- tag cells with row num + tagRow row = map ( (,) row ) + -- tag cells with column num + colTagged = map (zip [0..]) b + +-- | return current game state. +-- 'Win' if any cell is equal to or greater than 2048 +-- or 'Lose' if we can move no further +-- otherwise, 'Alive'. +gameState :: Board -> GameState +gameState b + | isWin + = if noFurther + then Win + else WinAlive + | noFurther + = Lose + | otherwise + = Alive + where + isWin = (any (>= 2048) . concat) b + noFurther = all (isNothing . ( `updateBoard` b)) universe + +-- | initialize the board by puting two cells randomly +-- into the board. +-- See 'generateNewCell' for the cell generating rule. +initGameBoard :: (MonadRandom r) => r (Board, Int) +initGameBoard = + -- insert two cells and return the resulting board + -- here we can safely assume that the board has at least two empty cells + -- so that we can never have Nothing on the LHS + liftM ( (\x -> (x,0)) . fromJust) (insertNewCell initBoard >>= (insertNewCell . fromJust)) + +-- | try to insert a new cell randomly +insertNewCell :: (MonadRandom r) => Board -> r (Maybe Board) +insertNewCell b = do + -- get a list of coordinates of blank cells + let availableCells = blankCells b + + if null availableCells + -- cannot find any empty cell, then fail + then return Nothing + else do + -- randomly pick up an available cell by choosing index + choice <- getRandomR (0, length availableCells - 1) + let (row,col) = availableCells !! choice + value <- generateNewCell + return $ Just $ (inPos row . inPos col) (const value) b + +-- | generate a new cell according to the game rule +-- we have 90% probability of getting a cell of value 2, +-- and 10% probability of getting a cell of value 4. +generateNewCell :: (MonadRandom r) => r Int +generateNewCell = do + r <- getRandom + return $ if r < (0.9 :: Float) then 2 else 4 diff --git a/src/Game/H2048/UI/Simple.hs b/src/Game/H2048/UI/Simple.hs new file mode 100644 --- /dev/null +++ b/src/Game/H2048/UI/Simple.hs @@ -0,0 +1,161 @@ +{-| + Module : Game.H2048.UI.Simple + Copyright : (c) 2014 Javran Cheng + License : MIT + Maintainer : Javran.C@gmail.com + Stability : experimental + Portability : POSIX + +A simple CLI implemention of Game 2048 + +-} +module Game.H2048.UI.Simple + ( drawBoard + , playGame + , mainSimple + ) +where + +import Game.H2048.Core + +import Data.List +import Text.Printf +import Control.Monad.IO.Class +import Control.Monad.Random +import Control.Arrow +import System.IO + +-- a simple UI implemented by outputing strings + +-- | simple help string +helpString :: String +helpString = "'i'/'k'/'j'/'l' to move, 'q' to quit." + +-- | pretty print the board to stdout +drawBoard :: Board -> IO () +drawBoard board = do + {- + when outputed, a cell will look like: + + +-----+ + | xxx | + +-----+ + + the pretty-printing strategy is to print the first line + and for each row in the board: + + * print the leftmost "| " + * let each cell in the row print " |" + * finalize this line by printing out the horizontal "+--+--+..." + -} + putStrLn horizSeparator + mapM_ drawRow board + where + cellWidth = length " 2048 " + -- build up the separator: "+--+--+....+" + horizSeparator' = + intercalate "+" (replicate 4 (replicate cellWidth '-')) + horizSeparator = "+" ++ horizSeparator' ++ "+" + + -- pretty string for a cell (without border) + prettyCell c = if c == 0 + then replicate cellWidth ' ' + else printf " %4d " c + + drawRow :: [Int] -> IO () + drawRow row = do + -- prints "| | | ... |" + putChar '|' + mapM_ (prettyCell >>> putStr >>> (>> putChar '|') ) row + putChar '\n' + putStrLn horizSeparator + +-- | play game on a given board until user quits or game ends +playGame :: (RandomGen g) => (Board, Int) -> RandT g IO () +playGame (b,score) = do + -- when game over + let endGame (b',score') win = do + drawBoard b' + putStrLn $ if win + then "You win" + else "Game over" + _ <- printf "Final score: %d\n" score' + hFlush stdout + -- handle user move, print the board together with current score, + -- return the next user move: + -- * return Nothing only if user has pressed "q" + -- * return Just if one of "ijkl" is pressed + handleUserMove win = do + let scoreFormat = + if win + then "You win, current score: %d\n" + else "Current score: %d\n" + drawBoard b + _ <- printf scoreFormat score + hFlush stdout + c <- getChar + putStrLn "" + hFlush stdout + + -- TODO: customizable + maybeKey <- case c of + 'q' -> return Nothing + 'i' -> putStrLn "Up" >> return (Just DUp) + 'k' -> putStrLn "Down" >> return (Just DDown) + 'j' -> putStrLn "Left" >> return (Just DLeft) + 'l' -> putStrLn "Right" >> return (Just DRight) + _ -> do + putStrLn helpString + return $ error "Unreachable code: unhandled invalid user input" + + if c `elem` "qijkl" + -- user will not be on this branch + -- if an invalid key is pressed + then return maybeKey + -- user will be trapped in "handleUserMove" unless + -- a valid key is given. So the error above (the wildcard case) + -- can never be reached + else handleUserMove win + handleGame = + maybe + -- user quit + (return ()) + -- user next move + -- 1. update the board according to user move + ((`updateBoard` b) >>> + -- 2. the update might succeed / fail + maybe + -- 2(a). the move is invalid, try again + (liftIO (putStrLn "Invalid move") >> playGame (b,score)) + -- 2(b). on success, insert new cell + (\ result -> do + -- should always succeed + -- because when a successful move is done + -- there is at least one empty cell in the board + (Just newB) <- insertNewCell (brBoard result) + -- keep going, accumulate score + playGame (newB, score + brScore result))) + + case gameState b of + Win -> + liftIO $ endGame (b,score) True + Lose -> + liftIO $ endGame (b,score) False + WinAlive -> + liftIO (handleUserMove True ) >>= handleGame + Alive -> + liftIO (handleUserMove False) >>= handleGame + +-- | the entry of Simple UI +mainSimple :: IO () +mainSimple = do + bfMod <- hGetBuffering stdin + -- no buffering - don't wait for the "enter" + hSetBuffering stdin NoBuffering + g <- newStdGen + -- in case someone don't read the README + putStrLn helpString + -- initialize game based on the random seed + _ <- evalRandT (initGameBoard >>= playGame) g + -- restoring buffering setting + hSetBuffering stdin bfMod diff --git a/src/Game/H2048/UI/Vty.hs b/src/Game/H2048/UI/Vty.hs new file mode 100644 --- /dev/null +++ b/src/Game/H2048/UI/Vty.hs @@ -0,0 +1,207 @@ +{-| + Module : Game.H2048.UI.Vty + Copyright : (c) 2014 Javran Cheng + License : MIT + Maintainer : Javran.C@gmail.com + Stability : experimental + Portability : POSIX + +A CLI version of Game 2048 implemented using vty-ui + +-} +{-# LANGUAGE OverloadedStrings #-} +module Game.H2048.UI.Vty + ( PlayState (..) + , mainVty + ) +where + +import Graphics.Vty.Widgets.All +import Graphics.Vty +import qualified Data.Text as T +import Control.Monad +import Control.Monad.Random +import Data.Foldable (foldMap) +import Data.IORef +import Data.Maybe + +import Game.H2048.Core + +-- | indicate the status of a playing session +data PlayState g = PlayState + { psBoard :: Board -- ^ current board + , psScore :: Int -- ^ current collected score + , psGState :: GameState -- ^ indicate whether the game terminates + , psRGen :: g -- ^ next random generator + } + +-- | flatten a 2D list, and keep the original +-- coordinate with the actual value, each element +-- in the resulting list looks like @({value},({row index},{colum index}))@. +toIndexedBoard :: Board -> [(Int, (Int, Int))] +toIndexedBoard b = concat $ zipWith go [0..] taggedCols + where + -- board with each cell tagged with its col num + taggedCols = map (zip [0..]) b + go :: Int -> [(Int,Int)] -> [(Int,(Int,Int))] + go row = map (\(col,val) -> (val,(row,col))) + +-- | calculate colors and styles for a given number +colorize :: Int -> [(T.Text, Attr)] +colorize i = [(s,attr)] + where + s = if i /= 0 then (T.pack . show) i else " " + attr = Attr (SetTo colorSty) (SetTo colorNum) Default + (colorSty, colorNum) = fromMaybe (bold,ISOColor 3) (lookup i colorDict) + colorDict = + [ ( 0, ( dim, ISOColor 0)) + , ( 2, ( dim, ISOColor 7)) + , ( 4, ( dim, ISOColor 6)) + , ( 8, ( dim, ISOColor 3)) + , ( 16, ( dim, ISOColor 2)) + , ( 32, ( dim, ISOColor 1)) + , ( 64, ( bold, ISOColor 7)) + , ( 128, ( bold, ISOColor 4)) + , ( 256, ( bold, ISOColor 6)) + , ( 512, ( bold, ISOColor 2)) + , (1024, ( bold, ISOColor 1)) + , (2048, ( bold, ISOColor 3)) + ] + +-- | render UI according to the PlayState +renderGame :: PlayState g -- ^ the PlayState + -> [[Widget FormattedText]] -- ^ cell widgets + -> Widget FormattedText -- ^ status bar widget + -> IO () +renderGame (PlayState bd sc gs _) items st = do + let ixBd = toIndexedBoard bd + renderCell v (row,col) = do + let item = items !! row !! col + -- for each cell, colorize it + -- and update the corresponding widget + item `setTextWithAttrs` colorize v + -- the beginning of status bar + scoreDesc = case gs of + Win -> "You win. Final score: " + Lose -> "Game over. Final score: " + Alive -> "Current score: " + WinAlive -> "You win, current score:" + + -- update table + mapM_ (uncurry renderCell) ixBd + -- update status bar + setText st $ T.pack (scoreDesc ++ show sc) + +-- | perform game update when a new direction is given +newDirGameUpdate :: (RandomGen g) + => IORef (PlayState g) -- ^ where PlayState is held + -> [[Widget FormattedText]] -- ^ cell widgets + -> Widget FormattedText -- ^ status bar + -> Dir -- ^ new direction + -> IO Bool +newDirGameUpdate psR items st dir = do + (PlayState b1 s1 gs1 g1) <- readIORef psR + let updated = updateBoard dir b1 + onSuccessUpdate (BoardUpdated b2 newS2) = do + -- if we are still alive, this insertion is always possible, + -- because a successful update means at least two cells + -- are merged together, leaving at least one empty cell + (Just b3,g2) <- runRandT (insertNewCell b2) g1 + -- create new PlayState, collect score, sync GameState + let ps2 = PlayState b3 (s1 + newS2) (gameState b3) g2 + renderGame ps2 items st + -- update PlayState to the IORef + writeIORef psR ps2 + return True + onAlive = + maybe + -- 2(a). update failed, invalid move, do nothing + (return True) + -- 2(b). updated successfully + onSuccessUpdate + -- 2. try to update the board + updated + + -- 1. only update if alive + case gs1 of + Win -> + return True + Lose -> + return True + Alive -> + onAlive + WinAlive -> + onAlive + +-- | the entry for vty-ui CLI implementation +mainVty :: IO () +mainVty = do + let cellSample :: String + cellSample = " 2048 " + cellLen = length cellSample + -- spec for a single cell + -- e.g.: + cellSpec = ColumnSpec (ColFixed cellLen) + (Just AlignRight) + (Just (padRight 1)) + helpString = "'i'/'k'/'j'/'l'/arrow keys to move, 'q' to quit." + + -- build up UI + tbl <- newTable (replicate 4 cellSpec) BorderFull + + pScore <- plainText " " + pHelp <- plainText helpString + hints <- hCentered pScore <--> hCentered pHelp + allW <- hCentered tbl <--> return hints + ui <- centered allW + + fg <- newFocusGroup + _ <- addToFocusGroup fg pScore + + -- the argument to plainText cannot be an empty string + -- otherwise the output would be weird + items <- (replicateM 4 . replicateM 4) (plainText " ") + + mapM_ (addRow tbl . foldMap mkRow) items + + -- prepare data and initialize + g <- newStdGen + ((bd,s),g') <- runRandT initGameBoard g + + -- keep track of playing state using IORef + let ps = PlayState bd s Alive g' + playStateR <- newIORef ps + + -- first rendering + renderGame ps items pScore + + c <- newCollection + _ <- addToCollection c ui fg + + -- shorthand for event update + let doUpdate = newDirGameUpdate playStateR items pScore + + pScore `onKeyPressed` \_ key _ -> + case key of + KASCII 'q' -> + shutdownUi >> return True + KASCII 'i' -> + doUpdate DUp + KUp -> + doUpdate DUp + KASCII 'k' -> + doUpdate DDown + KDown -> + doUpdate DDown + KASCII 'j' -> + doUpdate DLeft + KLeft -> + doUpdate DLeft + KASCII 'l' -> + doUpdate DRight + KRight -> + doUpdate DRight + _ -> + return False + + runUi c defaultContext diff --git a/src/Game/H2048/Utils.hs b/src/Game/H2048/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Game/H2048/Utils.hs @@ -0,0 +1,38 @@ +{-| + Module : Game.H2048.Utils + Copyright : (c) 2014 Javran Cheng + License : MIT + Maintainer : Javran.C@gmail.com + Stability : experimental + Portability : POSIX + +helper functions used when implementing game logic + +-} +module Game.H2048.Utils + ( inPos + , universe + ) +where + +-- provide utilities + +-- | all possible values for a Bounded Enum +universe :: (Bounded e, Enum e) => [e] +universe = [minBound .. maxBound] + +-- | modify a specified element in a list, +-- this is a simple semantic editor combinator +inPos :: Int -- ^ the index + -> (a -> a) -- ^ a function from the old element to the new one + -> [a] -- ^ the list to be modified + -> [a] +inPos n f xs + | null xs = xs + | n < 0 = xs + -- for all the cases below, + -- safely assume n >= 0 and xs is not empty + | n == 0 = let (y:ys) = xs + in f y : ys + | otherwise = let (y:ys) = xs + in y : inPos (n - 1) f ys diff --git a/src/MainSimple.hs b/src/MainSimple.hs --- a/src/MainSimple.hs +++ b/src/MainSimple.hs @@ -1,7 +1,7 @@ module Main where -import System.Game.H2048.UI.Simple +import Game.H2048.UI.Simple main :: IO () main = mainSimple diff --git a/src/MainVty.hs b/src/MainVty.hs --- a/src/MainVty.hs +++ b/src/MainVty.hs @@ -1,7 +1,7 @@ module Main where -import System.Game.H2048.UI.Vty +import Game.H2048.UI.Vty main :: IO () main = mainVty diff --git a/src/System/Game/H2048/Core.hs b/src/System/Game/H2048/Core.hs deleted file mode 100644 --- a/src/System/Game/H2048/Core.hs +++ /dev/null @@ -1,207 +0,0 @@ -{-| - Module : System.Game.H2048.Core - Copyright : (c) 2014 Javran Cheng - License : MIT - Maintainer : Javran.C@gmail.com - Stability : experimental - Portability : POSIX - -The core game logic implementation for Game 2048. - -The routine for using this library would be: - -1. use `initGameBoard` to get a valid board to begin with. -(two new cells are inserted for you, if you want to use an empty board, -`initBoard` is a shorthand) - -2. interact with user / algorithm / etc., use `updateBoard` to update a board. - -3. use `insertNewCell` to insert a new cell randomly - -4. examine if the player wins / loses / is still alive using `gameState`. - --} -module System.Game.H2048.Core - ( Board - , Line - , Dir (..) - , BoardUpdated (..) - , GameState (..) - , gameState - , compactLine - , initBoard - , initGameBoard - , updateBoard - , insertNewCell - , generateNewCell - ) -where - -import Control.Arrow -import Control.Monad -import Control.Monad.Writer -import Control.Monad.Random -import Data.List -import Data.Maybe - -import System.Game.H2048.Utils - --- | represent a 4x4 board for Game 2048 --- each element should be either zero or 2^i --- where i >= 1. -type Board = [[Int]] - --- | a list of 4 elements, stands for --- one column / row in the board -type Line = [Int] - --- | result after a successful 'updateBoard' -data BoardUpdated = BoardUpdated - { brBoard :: Board -- ^ new board - , brScore :: Int -- ^ score collected in this update - } deriving (Eq, Show) - --- | current game state, see also 'gameState' -data GameState = Win - | Lose - | Alive - deriving (Enum, Eq, Show) - --- | move direction -data Dir = DUp - | DDown - | DLeft - | DRight - deriving (Enum, Bounded, Eq, Ord, Show) - --- | the initial board before a game started -initBoard :: Board -initBoard = (replicate 4 . replicate 4) 0 - --- | move each non-zero element to their leftmost possible --- position while preserving the order -compactLine :: Line -> Writer (Sum Int) Line -compactLine = runKleisli - -- remove zeros - ( filter (/=0) - -- do merge and collect score - ^>> Kleisli merge - -- restore zeros, on the "fst" part - >>^ take 4 . (++ repeat 0)) - - where - merge :: [Int] -> Writer (Sum Int) [Int] - merge (x:y:xs) = - if x == y - -- only place where score are collected. - then do - -- try to merge first two elements, - -- and process rest of it. - xs' <- merge xs - tell . Sum $ x + y - return $ (x+y) : xs' - else do - -- just skip the first one, - -- and process rest of it. - xs' <- merge (y:xs) - return $ x : xs' - merge r = return r - --- | update the board taking a direction, --- a 'BoardUpdated' is returned on success, --- if this update does nothing, that means a failure (Nothing) -updateBoard :: Dir -> Board -> Maybe BoardUpdated -updateBoard d board = if board /= board' - then Just $ BoardUpdated board' (getSum score) - else Nothing - where - board' :: Board - -- transform boards so that - -- we only focus on "gravitize to the left". - -- and convert back after the gravitization is done. - (board',score) = runWriter $ - runKleisli - -- transform to a "gravitize to the left" problem - ( rTransL - -- gravitize to the left - ^>> Kleisli (mapM compactLine) - -- transform back - >>^ rTransR) board - - -- rTrans for "a list of reversible transformations, that will be performed in order" - rTrans :: [Board -> Board] - rTrans = - case d of - -- the problem itself is "gravitize to the left" - DLeft -> [] - -- we use a mirror - DRight -> [map reverse] - -- diagonal mirror - DUp -> [transpose] - -- same as DUp case + DRight case - DDown -> [transpose, map reverse] - - -- how we convert it "into" and "back" - rTransL = foldl (flip (.)) id rTrans - rTransR = foldr (.) id rTrans - --- | find blank cells in a board, --- return coordinates for each blank cell -blankCells :: Board -> [(Int, Int)] -blankCells b = map (\(row, (col, _)) -> (row,col)) blankCells' - where - blankCells' = filter ((== 0) . snd . snd) linearBoard - -- flatten to make it ready for filter - linearBoard = concat $ zipWith tagRow [0..] colTagged - - -- tag cells with row num - tagRow row = map ( (,) row ) - -- tag cells with column num - colTagged = map (zip [0..]) b - --- | return current game state. --- 'Win' if any cell is equal to or greater than 2048 --- or 'Lose' if we can move no further --- otherwise, 'Alive'. -gameState :: Board -> GameState -gameState b - | any (>= 2048) . concat $ b - = Win - | all (isNothing . ( `updateBoard` b)) universe - = Lose - | otherwise - = Alive - --- | initialize the board by puting two cells randomly --- into the board. --- See 'generateNewCell' for the cell generating rule. -initGameBoard :: (MonadRandom r) => r (Board, Int) -initGameBoard = - -- insert two cells and return the resulting board - -- here we can safely assume that the board has at least two empty cells - -- so that we can never have Nothing on the LHS - liftM ( (\x -> (x,0)) . fromJust) (insertNewCell initBoard >>= (insertNewCell . fromJust)) - --- | try to insert a new cell randomly -insertNewCell :: (MonadRandom r) => Board -> r (Maybe Board) -insertNewCell b = do - -- get a list of coordinates of blank cells - let availableCells = blankCells b - - if null availableCells - -- cannot find any empty cell, then fail - then return Nothing - else do - -- randomly pick up an available cell by choosing index - choice <- getRandomR (0, length availableCells - 1) - let (row,col) = availableCells !! choice - value <- generateNewCell - return $ Just $ (inPos row . inPos col) (const value) b - --- | generate a new cell according to the game rule --- we have 90% probability of getting a cell of value 2, --- and 10% probability of getting a cell of value 4. -generateNewCell :: (MonadRandom r) => r Int -generateNewCell = do - r <- getRandom - return $ if r < (0.9 :: Float) then 2 else 4 diff --git a/src/System/Game/H2048/UI/Simple.hs b/src/System/Game/H2048/UI/Simple.hs deleted file mode 100644 --- a/src/System/Game/H2048/UI/Simple.hs +++ /dev/null @@ -1,144 +0,0 @@ -module System.Game.H2048.UI.Simple - ( drawBoard - , playGame - , mainSimple - ) -where - -import System.Game.H2048.Core - -import Data.List -import Text.Printf -import Control.Monad.IO.Class -import Control.Monad.Random -import Control.Arrow -import System.IO - --- a simple UI implemented by outputing strings - --- | simple help string -helpString :: String -helpString = "'i'/'k'/'j'/'l' to move, 'q' to quit." - --- | pretty print the board to stdout -drawBoard :: Board -> IO () -drawBoard board = do - {- - when outputed, a cell will look like: - - +-----+ - | xxx | - +-----+ - - the pretty-printing strategy is to print the first line - and for each row in the board: - - * print the leftmost "| " - * let each cell in the row print " |" - * finalize this line by printing out the horizontal "+--+--+..." - -} - putStrLn horizSeparator - mapM_ drawRow board - where - cellWidth = length " 2048 " - -- build up the separator: "+--+--+....+" - horizSeparator' = - intercalate "+" (replicate 4 (replicate cellWidth '-')) - horizSeparator = "+" ++ horizSeparator' ++ "+" - - -- pretty string for a cell (without border) - prettyCell c = if c == 0 - then replicate cellWidth ' ' - else printf " %4d " c - - drawRow :: [Int] -> IO () - drawRow row = do - -- prints "| | | ... |" - putChar '|' - mapM_ (prettyCell >>> putStr >>> (>> putChar '|') ) row - putChar '\n' - putStrLn horizSeparator - --- | play game on a given board until user quits or game ends -playGame :: (RandomGen g) => (Board, Int) -> RandT g IO () -playGame (b,score) = do - -- when game over - let endGame (b',score') win = do - drawBoard b' - putStrLn $ if win - then "You win" - else "Game over" - _ <- printf "Final score: %d\n" score' - hFlush stdout - -- handle user move, print the board together with current score, - -- return the next user move: - -- * return Nothing only if user has pressed "q" - -- * return Just if one of "ijkl" is pressed - handleUserMove = do - drawBoard b - _ <- printf "Current score: %d\n" score - hFlush stdout - c <- getChar - putStrLn "" - hFlush stdout - - -- TODO: customizable - maybeKey <- case c of - 'q' -> return Nothing - 'i' -> putStrLn "Up" >> return (Just DUp) - 'k' -> putStrLn "Down" >> return (Just DDown) - 'j' -> putStrLn "Left" >> return (Just DLeft) - 'l' -> putStrLn "Right" >> return (Just DRight) - _ -> do - putStrLn helpString - return $ error "Unreachable code: unhandled invalid user input" - - if c `elem` "qijkl" - -- user will not be on this branch - -- if an invalid key is pressed - then return maybeKey - -- user will be trapped in "handleUserMove" unless - -- a valid key is given. So the error above (the wildcard case) - -- can never be reached - else handleUserMove - handleGame = - maybe - -- user quit - (return ()) - -- user next move - -- 1. update the board according to user move - ((`updateBoard` b) >>> - -- 2. the update might succeed / fail - maybe - -- 2(a). the move is invalid, try again - (liftIO (putStrLn "Invalid move") >> playGame (b,score)) - -- 2(b). on success, insert new cell - (\ result -> do - -- should always succeed - -- because when a successful move is done - -- there is at least one empty cell in the board - (Just newB) <- insertNewCell (brBoard result) - -- keep going, accumulate score - playGame (newB, score + brScore result))) - - case gameState b of - Win -> - liftIO $ endGame (b,score) True - Lose -> - liftIO $ endGame (b,score) False - Alive -> - liftIO handleUserMove >>= handleGame - --- | the entry of Simple UI -mainSimple :: IO () -mainSimple = do - bfMod <- hGetBuffering stdin - -- no buffering - don't wait for the "enter" - hSetBuffering stdin NoBuffering - g <- newStdGen - -- in case someone don't read the README - putStrLn helpString - -- initialize game based on the random seed - _ <- evalRandT (initGameBoard >>= playGame) g - -- restoring buffering setting - hSetBuffering stdin bfMod diff --git a/src/System/Game/H2048/UI/Vty.hs b/src/System/Game/H2048/UI/Vty.hs deleted file mode 100644 --- a/src/System/Game/H2048/UI/Vty.hs +++ /dev/null @@ -1,190 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module System.Game.H2048.UI.Vty - ( PlayState (..) - , mainVty - ) -where - -import Graphics.Vty.Widgets.All -import Graphics.Vty -import qualified Data.Text as T -import Control.Monad -import Control.Monad.Random -import Data.Foldable (foldMap) -import Data.IORef -import Data.Maybe - -import System.Game.H2048.Core - --- | indicate the status of a playing session -data PlayState g = PlayState - { psBoard :: Board -- ^ current board - , psScore :: Int -- ^ current collected score - , psGState :: GameState -- ^ indicate whether the game terminates - , psRGen :: g -- ^ next random generator - } - --- | flatten a 2D list, and keep the original --- coordinate with the actual value, each element --- in the resulting list looks like @({value},({row index},{colum index}))@. -toIndexedBoard :: Board -> [(Int, (Int, Int))] -toIndexedBoard b = concat $ zipWith go [0..] taggedCols - where - -- board with each cell tagged with its col num - taggedCols = map (zip [0..]) b - go :: Int -> [(Int,Int)] -> [(Int,(Int,Int))] - go row = map (\(col,val) -> (val,(row,col))) - --- | calculate colors and styles for a given number -colorize :: Int -> [(T.Text, Attr)] -colorize i = [(s,attr)] - where - s = if i /= 0 then (T.pack . show) i else " " - attr = Attr (SetTo colorSty) (SetTo colorNum) Default - (colorSty, colorNum) = fromMaybe (bold,ISOColor 3) (lookup i colorDict) - colorDict = - [ ( 0, ( dim, ISOColor 0)) - , ( 2, ( dim, ISOColor 7)) - , ( 4, ( dim, ISOColor 6)) - , ( 8, ( dim, ISOColor 3)) - , ( 16, ( dim, ISOColor 2)) - , ( 32, ( dim, ISOColor 1)) - , ( 64, ( bold, ISOColor 7)) - , ( 128, ( bold, ISOColor 4)) - , ( 256, ( bold, ISOColor 6)) - , ( 512, ( bold, ISOColor 2)) - , (1024, ( bold, ISOColor 1)) - , (2048, ( bold, ISOColor 3)) - ] - --- | render UI according to the PlayState -renderGame :: PlayState g -- ^ the PlayState - -> [[Widget FormattedText]] -- ^ cell widgets - -> Widget FormattedText -- ^ status bar widget - -> IO () -renderGame (PlayState bd sc gs _) items st = do - let ixBd = toIndexedBoard bd - renderCell v (row,col) = do - let item = items !! row !! col - -- for each cell, colorize it - -- and update the corresponding widget - item `setTextWithAttrs` colorize v - -- the beginning of status bar - scoreDesc = case gs of - Win -> "You win. Final Score: " - Lose -> "Game Over. Final Score: " - Alive -> "Current Score: " - - -- update table - mapM_ (uncurry renderCell) ixBd - -- update status bar - setText st $ T.pack (scoreDesc ++ show sc) - --- | perform game update when a new direction is given -newDirGameUpdate :: (RandomGen g) - => IORef (PlayState g) -- ^ where PlayState is held - -> [[Widget FormattedText]] -- ^ cell widgets - -> Widget FormattedText -- ^ status bar - -> Dir -- ^ new direction - -> IO Bool -newDirGameUpdate psR items st dir = do - (PlayState b1 s1 gs1 g1) <- readIORef psR - let updated = updateBoard dir b1 - onSuccessUpdate (BoardUpdated b2 newS2) = do - -- if we are still alive, this insertion is always possible, - -- because a successful update means at least two cells - -- are merged together, leaving at least one empty cell - (Just b3,g2) <- runRandT (insertNewCell b2) g1 - -- create new PlayState, collect score, sync GameState - let ps2 = PlayState b3 (s1 + newS2) (gameState b3) g2 - renderGame ps2 items st - -- update PlayState to the IORef - writeIORef psR ps2 - return True - -- 1. only update if alive - case gs1 of - Win -> - return True - Lose -> - return True - Alive -> - maybe - -- 2(a). update failed, invalid move, do nothing - (return True) - -- 2(b). updated successfully - onSuccessUpdate - -- 2. try to update the board - updated - --- | the entry for vty-ui CLI implementation -mainVty :: IO () -mainVty = do - let cellSample :: String - cellSample = " 2048 " - cellLen = length cellSample - -- spec for a single cell - -- e.g.: - cellSpec = ColumnSpec (ColFixed cellLen) - (Just AlignRight) - (Just (padRight 1)) - helpString = "'i'/'k'/'j'/'l'/arrow keys to move, 'q' to quit." - - -- build up UI - tbl <- newTable (replicate 4 cellSpec) BorderFull - - pScore <- plainText " " - pHelp <- plainText helpString - hints <- hCentered pScore <--> hCentered pHelp - allW <- hCentered tbl <--> return hints - ui <- centered allW - - fg <- newFocusGroup - _ <- addToFocusGroup fg pScore - - -- the argument to plainText cannot be an empty string - -- otherwise the output would be weird - items <- (replicateM 4 . replicateM 4) (plainText " ") - - mapM_ (addRow tbl . foldMap mkRow) items - - -- prepare data and initialize - g <- newStdGen - ((bd,s),g') <- runRandT initGameBoard g - - -- keep track of playing state using IORef - let ps = PlayState bd s Alive g' - playStateR <- newIORef ps - - -- first rendering - renderGame ps items pScore - - c <- newCollection - _ <- addToCollection c ui fg - - -- shorthand for event update - let doUpdate = newDirGameUpdate playStateR items pScore - - pScore `onKeyPressed` \_ key _ -> - case key of - KASCII 'q' -> - shutdownUi >> return True - KASCII 'i' -> - doUpdate DUp - KUp -> - doUpdate DUp - KASCII 'k' -> - doUpdate DDown - KDown -> - doUpdate DDown - KASCII 'j' -> - doUpdate DLeft - KLeft -> - doUpdate DLeft - KASCII 'l' -> - doUpdate DRight - KRight -> - doUpdate DRight - _ -> - return False - - runUi c defaultContext diff --git a/src/System/Game/H2048/Utils.hs b/src/System/Game/H2048/Utils.hs deleted file mode 100644 --- a/src/System/Game/H2048/Utils.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-| - Module : System.Game.H2048.Utils - Copyright : (c) 2014 Javran Cheng - License : MIT - Maintainer : Javran.C@gmail.com - Stability : experimental - Portability : POSIX - -helper functions used when implementing game logic - --} -module System.Game.H2048.Utils - ( inPos - , universe - ) -where - --- provide utilities - --- | all possible values for a Bounded Enum -universe :: (Bounded e, Enum e) => [e] -universe = [minBound .. maxBound] - --- | modify a specified element in a list, --- this is a simple semantic editor combinator -inPos :: Int -- ^ the index - -> (a -> a) -- ^ a function from the old element to the new one - -> [a] -- ^ the list to be modified - -> [a] -inPos n f xs - | null xs = xs - | n < 0 = xs - -- for all the cases below, - -- safely assume n >= 0 and xs is not empty - | n == 0 = let (y:ys) = xs - in f y : ys - | otherwise = let (y:ys) = xs - in y : inPos (n - 1) f ys diff --git a/src/Test.hs b/src/Test.hs --- a/src/Test.hs +++ b/src/Test.hs @@ -5,7 +5,7 @@ import Control.Monad.Writer import System.Exit -import System.Game.H2048.Core +import Game.H2048.Core -- | the expected behavior of 'compactLine' compactLineTestcases :: [ ((Line, Int) , Line) ] @@ -30,41 +30,41 @@ -- | the expected behavior of 'gameState' gameStateTestcases :: [ (String, GameState, Board) ] gameStateTestcases = - [ ( "trivial win", - Win , [ [ 2048, 2048, 2048, 2048 ] - , [ 0, 0, 0, 0 ] - , [ 0, 0, 0, 0 ] - , [ 0, 0, 0, 0 ] ] ) + [ ( "trivial win, alive", + WinAlive , [ [ 2048, 2048, 2048, 2048 ] + , [ 0, 0, 0, 0 ] + , [ 0, 0, 0, 0 ] + , [ 0, 0, 0, 0 ] ] ) , ( "more than 2048 (might not happen in practice)", - Win , [ [ 256, 2, 4, 8 ] - , [ 16, 32, 64, 128 ] - , [ 256, 512, 1024, 8 ] - , [ 16, 4096, 128, 64 ] ] ) + Win , [ [ 256, 2, 4, 8 ] + , [ 16, 32, 64, 128 ] + , [ 256, 512, 1024, 8 ] + , [ 16, 4096, 128, 64 ] ] ) , ( "no more move but win", - Win , [ [ 2, 4, 2, 4 ] - , [ 4, 2048, 4, 2 ] - , [ 2, 4, 2, 4 ] - , [ 4, 2, 4, 2 ] ] ) + Win , [ [ 2, 4, 2, 4 ] + , [ 4, 2048, 4, 2 ] + , [ 2, 4, 2, 4 ] + , [ 4, 2, 4, 2 ] ] ) , ( "trivial alive", - Alive , [ [ 2, 0, 0, 8 ] - , [ 4, 0, 0, 8 ] - , [ 4, 0, 0, 8 ] - , [ 1024, 512, 128, 64 ] ] ) + Alive , [ [ 2, 0, 0, 8 ] + , [ 4, 0, 0, 8 ] + , [ 4, 0, 0, 8 ] + , [ 1024, 512, 128, 64 ] ] ) , ( "no empty cell but still alive", - Alive , [ [ 512, 128, 512, 128 ] - , [ 128, 512, 128, 512 ] - , [ 512, 128, 512, 128 ] - , [ 128, 512, 128, 128 ] ] ) + Alive , [ [ 512, 128, 512, 128 ] + , [ 128, 512, 128, 512 ] + , [ 512, 128, 512, 128 ] + , [ 128, 512, 128, 128 ] ] ) , ( "trivial lose 1", - Lose , [ [ 2, 4, 2, 4 ] - , [ 4, 2, 4, 2 ] - , [ 2, 4, 2, 4 ] - , [ 4, 2, 4, 2 ] ] ) + Lose , [ [ 2, 4, 2, 4 ] + , [ 4, 2, 4, 2 ] + , [ 2, 4, 2, 4 ] + , [ 4, 2, 4, 2 ] ] ) , ( "trivial lose 2", - Lose , [ [ 2, 8, 32, 2 ] - , [ 4, 2, 8, 4 ] - , [ 32, 16, 128, 16 ] - , [ 4, 8, 4, 2 ] ] ) + Lose , [ [ 2, 8, 32, 2 ] + , [ 4, 2, 8, 4 ] + , [ 32, 16, 128, 16 ] + , [ 4, 8, 4, 2 ] ] ) ] gameStateTests :: Test