h2048 0.1.0.1 → 0.1.0.2
raw patch · 3 files changed
+348/−6 lines, 3 filesdep +h2048
Dependencies added: h2048
Files
- h2048.cabal +14/−6
- src/System/Game/H2048/UI/Simple.hs +144/−0
- src/System/Game/H2048/UI/Vty.hs +190/−0
h2048.cabal view
@@ -2,7 +2,7 @@ -- see http://haskell.org/cabal/users-guide/ name: h2048-version: 0.1.0.1+version: 0.1.0.2 synopsis: a haskell implementation of Game 2048 description: a haskell implementation of Game 2048, based on <https://github.com/gabrielecirulli/2048>.@@ -29,12 +29,17 @@ library hs-source-dirs: src exposed-modules: System.Game.H2048.Core,- System.Game.H2048.Utils+ System.Game.H2048.Utils,+ System.Game.H2048.UI.Simple,+ System.Game.H2048.UI.Vty build-depends: base >= 4 && < 5, transformers >= 0 && < 1, mtl >= 2 && < 3,- MonadRandom >= 0 && < 1+ MonadRandom >= 0 && < 1,+ text >= 1 && < 2,+ vty >= 4 && < 5,+ vty-ui >= 1 && < 2 ghc-options: -Wall default-language: Haskell2010@@ -46,7 +51,8 @@ build-depends: base >= 4 && < 5, transformers >= 0 && < 1, mtl >= 2 && < 3,- MonadRandom >= 0 && < 1+ MonadRandom >= 0 && < 1,+ h2048 >= 0 && < 1 if ! flag(exe) buildable: False@@ -63,7 +69,8 @@ vty-ui >= 1 && < 2, transformers >= 0 && < 1, mtl >= 2 && < 3,- MonadRandom >= 0 && < 1+ MonadRandom >= 0 && < 1,+ h2048 >= 0 && < 1 if ! flag(exe) || ! flag(vty) buildable: False@@ -79,6 +86,7 @@ MonadRandom >= 0 && < 1, transformers >= 0 && < 1, mtl >= 2 && < 3,- HUnit >= 1 && < 2+ HUnit >= 1 && < 2,+ h2048 >= 0 && < 1 default-language: Haskell2010
+ src/System/Game/H2048/UI/Simple.hs view
@@ -0,0 +1,144 @@+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 view
@@ -0,0 +1,190 @@+{-# 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