h2048 0.1.0.2 → 0.2.0.0
raw patch · 14 files changed
+697/−643 lines, 14 filesdep −h2048dep ~vty
Dependencies removed: h2048
Dependency ranges changed: vty
Files
- CHANGELOG.md +6/−0
- README.md +21/−16
- h2048.cabal +19/−16
- src/Game/H2048/Core.hs +213/−0
- src/Game/H2048/UI/Simple.hs +161/−0
- src/Game/H2048/UI/Vty.hs +207/−0
- src/Game/H2048/Utils.hs +38/−0
- src/MainSimple.hs +1/−1
- src/MainVty.hs +1/−1
- src/System/Game/H2048/Core.hs +0/−207
- src/System/Game/H2048/UI/Simple.hs +0/−144
- src/System/Game/H2048/UI/Vty.hs +0/−190
- src/System/Game/H2048/Utils.hs +0/−38
- src/Test.hs +30/−30
+ CHANGELOG.md view
@@ -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`
README.md view
@@ -2,47 +2,52 @@ [](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 -+ ## vty CLI version -+ ## 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
h2048.cabal view
@@ -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 <https://github.com/gabrielecirulli/2048>.+description: + A haskell implementation of Game 2048,+ based on <https://github.com/gabrielecirulli/2048>.+ 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
+ src/Game/H2048/Core.hs view
@@ -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
+ src/Game/H2048/UI/Simple.hs view
@@ -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 " <number> |"+ * 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 "| <cell1> | <cell2> | ... |"+ 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 <key> 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
+ src/Game/H2048/UI/Vty.hs view
@@ -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 " <Score> "+ 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
+ src/Game/H2048/Utils.hs view
@@ -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
src/MainSimple.hs view
@@ -1,7 +1,7 @@ module Main where -import System.Game.H2048.UI.Simple+import Game.H2048.UI.Simple main :: IO () main = mainSimple
src/MainVty.hs view
@@ -1,7 +1,7 @@ module Main where -import System.Game.H2048.UI.Vty+import Game.H2048.UI.Vty main :: IO () main = mainVty
− src/System/Game/H2048/Core.hs
@@ -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
− src/System/Game/H2048/UI/Simple.hs
@@ -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 " <number> |"- * 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 "| <cell1> | <cell2> | ... |"- 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 <key> 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
− src/System/Game/H2048/UI/Vty.hs
@@ -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 " <Score> "- 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
− src/System/Game/H2048/Utils.hs
@@ -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
src/Test.hs view
@@ -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