diff --git a/h2048.cabal b/h2048.cabal --- a/h2048.cabal +++ b/h2048.cabal @@ -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 . @@ -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 diff --git a/src/System/Game/H2048/UI/Simple.hs b/src/System/Game/H2048/UI/Simple.hs new file mode 100644 --- /dev/null +++ b/src/System/Game/H2048/UI/Simple.hs @@ -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 " |" + * 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 new file mode 100644 --- /dev/null +++ b/src/System/Game/H2048/UI/Vty.hs @@ -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 " " + 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