diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,10 +1,14 @@ +# 1.0.0.0 (pending) + +- scrap direct `vty` support due to its deprecation. + # 0.2.0.1 -* build with vty 5 and vty-ui 1.8 (thanks to @vikraman) +- build with vty 5 and vty-ui 1.8 (thanks to @vikraman) # 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` +- 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/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,6 @@ The MIT License (MIT) -Copyright (c) 2014 Javran Cheng +Copyright (c) 2014-2019 Javran Cheng Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/exe/BrickUi.hs b/exe/BrickUi.hs new file mode 100644 --- /dev/null +++ b/exe/BrickUi.hs @@ -0,0 +1,3 @@ +module BrickUi (main) where + +import Game.H2048.UI.Brick diff --git a/exe/Simple.hs b/exe/Simple.hs new file mode 100644 --- /dev/null +++ b/exe/Simple.hs @@ -0,0 +1,3 @@ +module Simple (main) where + +import Game.H2048.UI.Simple diff --git a/h2048.cabal b/h2048.cabal --- a/h2048.cabal +++ b/h2048.cabal @@ -1,95 +1,98 @@ --- Initial h2048.cabal generated by cabal init. For further documentation, --- see http://haskell.org/cabal/users-guide/ - -name: h2048 -version: 0.2.0.1 -synopsis: a haskell implementation of Game 2048 +cabal-version: 1.12 +name: h2048 +version: 0.3.0.0 +license: MIT +license-file: LICENSE +maintainer: Javran.C@gmail.com +author: Javran Cheng +homepage: https://github.com/Javran/h2048#readme +bug-reports: https://github.com/Javran/h2048/issues +synopsis: An Implementation of Game 2048 description: - - A haskell implementation of Game 2048, - based on . - -homepage: https://github.com/Javran/h2048 -license: MIT -license-file: LICENSE -author: Javran Cheng -maintainer: Javran.C@gmail.com -copyright: Copyright (c) 2014 Javran Cheng -category: Game -build-type: Simple -extra-source-files: README.md, CHANGELOG.md -cabal-version: >=1.10 - -flag exe - description: build executables - default: True + An Implementation of Game 2048, based on . +category: Game +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md -flag vty - description: build UI written in vty-ui - default: True +source-repository head + type: git + location: https://github.com/Javran/h2048 library - hs-source-dirs: src - 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 >= 5 && < 6, - vty-ui >= 1.8 && < 2 + Game.H2048.Core + Game.H2048.UI.Brick + Game.H2048.UI.Simple + Game.H2048.Utils + hs-source-dirs: src + other-modules: + Paths_h2048 + default-language: Haskell2010 + build-depends: + MonadRandom >=0.5.1.1 && <0.6, + base >=4.12.0.0 && <4.13, + brick >=0.47.1 && <0.48, + lens >=4.17.1 && <4.18, + mtl >=2.2.2 && <2.3, + text >=1.2.3.1 && <1.3, + vty >=5.25.1 && <5.26 - ghc-options: -Wall - default-language: Haskell2010 +executable h2048-brick + main-is: BrickUi.hs + hs-source-dirs: exe + other-modules: + Simple + Paths_h2048 + default-language: Haskell2010 + ghc-options: -threaded -O2 -rtsopts -with-rtsopts=-N -main-is + BrickUi + build-depends: + MonadRandom >=0.5.1.1 && <0.6, + base >=4.12.0.0 && <4.13, + brick >=0.47.1 && <0.48, + h2048 -any, + lens >=4.17.1 && <4.18, + mtl >=2.2.2 && <2.3, + text >=1.2.3.1 && <1.3, + vty >=5.25.1 && <5.26 executable h2048-simple - hs-source-dirs: src - main-is: MainSimple.hs - ghc-options: -Wall - build-depends: base >= 4 && < 5, - transformers >= 0 && < 1, - mtl >= 2 && < 3, - MonadRandom >= 0 && < 1 - - if ! flag(exe) - buildable: False - - default-language: Haskell2010 - -executable h2048-vty - hs-source-dirs: src - main-is: MainVty.hs - ghc-options: -Wall -threaded - build-depends: base >= 4 && < 5, - text >= 1 && < 2, - vty >= 5 && < 6, - vty-ui >= 1.8 && < 2, - transformers >= 0 && < 1, - mtl >= 2 && < 3, - MonadRandom >= 0 && < 1 - - if ! flag(exe) || ! flag(vty) - buildable: False - - default-language: Haskell2010 - -Test-Suite test - hs-source-dirs: src - type: exitcode-stdio-1.0 - main-is: Test.hs - ghc-options: -Wall - build-depends: base >= 4 && < 5, - MonadRandom >= 0 && < 1, - transformers >= 0 && < 1, - mtl >= 2 && < 3, - HUnit >= 1 && < 2 + main-is: Simple.hs + hs-source-dirs: exe + other-modules: + BrickUi + Paths_h2048 + default-language: Haskell2010 + ghc-options: -threaded -O2 -rtsopts -with-rtsopts=-N -main-is + Simple + build-depends: + MonadRandom >=0.5.1.1 && <0.6, + base >=4.12.0.0 && <4.13, + brick >=0.47.1 && <0.48, + h2048 -any, + lens >=4.17.1 && <4.18, + mtl >=2.2.2 && <2.3, + text >=1.2.3.1 && <1.3, + vty >=5.25.1 && <5.26 - default-language: Haskell2010 +test-suite hspec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test + other-modules: + Game.H2048.CoreSpec + Paths_h2048 + default-language: Haskell2010 + ghc-options: -threaded -O2 -rtsopts -with-rtsopts=-N -main-is Spec + build-depends: + MonadRandom >=0.5.1.1 && <0.6, + base >=4.12.0.0 && <4.13, + brick >=0.47.1 && <0.48, + h2048 -any, + hspec >=2.7.1 && <2.8, + lens >=4.17.1 && <4.18, + mtl >=2.2.2 && <2.3, + text >=1.2.3.1 && <1.3, + vty >=5.25.1 && <5.26 diff --git a/src/Game/H2048/Core.hs b/src/Game/H2048/Core.hs --- a/src/Game/H2048/Core.hs +++ b/src/Game/H2048/Core.hs @@ -21,193 +21,234 @@ 4. examine if the player wins / loses / is still alive using `gameState`. -} +{-# LANGUAGE TupleSections, FlexibleContexts, RankNTypes #-} module Game.H2048.Core - ( Board - , Line - , Dir (..) - , BoardUpdated (..) - , GameState (..) - , gameState - , compactLine - , initBoard - , initGameBoard - , updateBoard - , insertNewCell - , generateNewCell - ) + ( Dir (..) + , BoardUpdateResult + , Board + , mkBoard + , fromBoard + , defBoard + , Line + , mkLine + , defLine + , gameState + , GameState(..) + , compactLine' + , compactLine + , initGameBoard + , updateBoard + , insertNewCell + , nextMoves + ) where -import Control.Arrow -import Control.Monad -import Control.Monad.Writer -import Control.Monad.Random import Data.List import Data.Maybe +import Control.Applicative +import Control.Monad.Writer +import Control.Monad.Random +import Data.Coerce +import Control.Lens + 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]] +newtype Board = Board [Line] +data GameState = GS + { hasWon :: Bool + , isAlive :: Bool + } deriving (Eq, Show) + +{- + TODO: I think the problem with current Board & Line is that + it is too fancy and in some sense restrictive + for the work it needs to do - all this transposing + and isomorphism stuff looks nice at first but using lens is really an overkill + and we don't really have many performance gain to begin with. + regarding the "restrictive" bit: Line is really just a list of four elements + and this makes it hard to extend to say 5x5 or non-square board. + What I want to try is to use a Map structure instead: + - when collapsing a line, the sequence of coordinates are computed to + extract the line from board, process as if it is a list of cells + and write it back afterwards. + + Also I want to try out another idea: + define `newtype Cell = Cell Int`, where `merge :: Cell -> Cell -> Maybe Cell` + merges two cell only if two embedding numbers are same (say i) + and the result is `Just (Cell (i+1))` this saves a little bit space + and allows us to use stuff other than 1,2,4,8... + -} +mkBoard :: [[Int]] -> Board +mkBoard = Board . take 4 . (++ repeat defLine) . (mkLine <$>) + +fromBoard :: Board -> [[Int]] +fromBoard = coerce + -- | a list of 4 elements, stands for -- one column / row in the board -type Line = [Int] +{- + Alternatively Line could be a ~ Int => (a,a,a,a) + and Board being a ~ Line -> (a,a,a,a), + we should be able to utilize fixed-vector. + but here we don't have a user-friendly set of tools + to deal with traversal (at least not that I'm aware of), + so I guess for now we can still stick to List. +-} +newtype Line = Line [Int] deriving (Eq, Show) + +mkLine :: [Int] -> Line +mkLine = Line . take 4 . (++ repeat 0) + +defLine :: Line +defLine = mkLine [] + -- | result after a successful 'updateBoard' -data BoardUpdated = BoardUpdated - { brBoard :: Board -- ^ new board - , brScore :: Int -- ^ score collected in this update - } deriving (Eq, Show) +type BoardUpdateResult = (Board, Int) --- | 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) +{- + notice that we don't need GameState at all: + - at any point in time, the game is won when we have a cell that contains a value + >= 2048 + - when there are possible moves, we are not done yet, + otherwise the game is lost. + therefore we could probably return a list of pairs of + (, (Sum Int, Line) +compactLine' (Line l) = mkLine <$> merge (filter (/= 0) l) + where + merge r = case r of + (x:y:xs) -> + if x == y + -- only place where score are collected. + then + -- try to merge first two elements, + -- and process rest of it. + let s = x+y + in tell (Sum s) >> (s:) <$> merge xs + else + -- just skip the first one, + -- and process rest of it. + (x:) <$> merge (y:xs) + _ -> pure r + -- | 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 +compactLine :: MonadWriter (Sum Int) m => Line -> m Line +compactLine l = let (v, l') = compactLine' l in writer (l', v) -- | 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 +-- note that here "update" does not include adding one random cell of 2 or 4 +-- into the board +updateBoard :: Dir -> Board -> Maybe BoardUpdateResult +updateBoard d (Board board) = do + guard $ board /= board' + pure (Board board', getSum score) + where + -- transform boards so that + -- we only focus on "gravitize to the left". + -- and convert back after the gravitization is done. + (board',score) = runWriter $ withIso (getIso d) $ + \g f -> g <$> mapM compactLine (f 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] +getIso :: Dir -> Iso' [Line] [Line] +getIso d = c . ik . from c + where + ik = case d of + DLeft -> id + DRight -> sRight + DUp -> sUp + DDown -> sRight . sUp + c :: Iso' [Line] [[Int]] + c = coerced - -- how we convert it "into" and "back" - rTransL = foldl (flip (.)) id rTrans - rTransR = foldr (.) id rTrans + sRight = involuted (map reverse) + sUp = involuted transpose +nextMoves :: Board -> [(Dir, BoardUpdateResult)] +nextMoves b = mapMaybe (\d -> (d,) <$> updateBoard d b) allDirs + -- | 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 +blankCells (Board b) = map (\(row, (col, _)) -> (row,col)) blankCells' + where + {- + the algorithm is to just find all empty cells - + we could of course keep track of all empty cells, + but that will be overcomplicated and hard to maintain + when we do "compactLine" + -} + 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 + -- tag cells with row num + tagRow row = map (row,) + -- tag cells with column num + colTagged = map (zip [0..] . (coerce :: Line -> [Int])) 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 +gameState nb@(Board b) = GS hw alv + where + hw = (any (>= 2048) . concatMap (coerce :: Line -> [Int])) b + alv = not . null . nextMoves $ nb -- | 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 :: (MonadRandom m, Alternative m) => m (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)) + (,0) . fromJust <$> (insertNewCell defBoard >>= (insertNewCell . fromJust)) -- | try to insert a new cell randomly -insertNewCell :: (MonadRandom r) => Board -> r (Maybe Board) +insertNewCell :: (MonadRandom r, Alternative 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 + guard $ (not . null) availableCells + -- randomly pick up an available cell by choosing index + choice <- getRandomR (0, length availableCells - 1) + let (row,col) = availableCells !! choice + value <- generateNewCell + let (Board b') = b + c1 :: ([Int] -> [Int]) -> Line -> Line + c1 = coerce + pure $ Just $ Board $ (inPos row . c1 . 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 +generateNewCell = getRandom >>= \r -> + pure $ if r < (0.9 :: Float) then 2 else 4 diff --git a/src/Game/H2048/UI/Brick.hs b/src/Game/H2048/UI/Brick.hs new file mode 100644 --- /dev/null +++ b/src/Game/H2048/UI/Brick.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE OverloadedStrings, NamedFieldPuns #-} +module Game.H2048.UI.Brick where + +import Brick +import Brick.Widgets.Border +import Brick.Widgets.Center +import Data.Bits +import Data.Functor +import Data.List +import Data.String +import Data.Maybe +import Graphics.Vty.Attributes +import Graphics.Vty.Input.Events +import Control.Monad.IO.Class + +import Game.H2048.Core + +data RName = RBoard deriving (Eq, Ord) + +type AppState = (Board, Int {- for tracking total score -}) + +valToTier :: Int -> Int +valToTier = countTrailingZeros -- tier starting from 1 + +tierAttr :: Int -> AttrName +tierAttr = ("tier" <>) . fromString . show + +boardSample :: Board +boardSample = mkBoard + [ [1,2,4,8] + , [16,32,64,128] + , [256,512,1024,2048] + , [0,0,0,0] + ] + +boardWidget :: AppState -> Widget RName +boardWidget (bdOpaque, _) = + joinBorders + . border + $ grid + where + bd = fromBoard bdOpaque + grid = + hLimit (hMax*4+3) $ vBox (intersperse hBorder (row <$> [0..3])) + row :: Int -> Widget RName + row r = + vLimit 1 $ + hBox (intersperse vBorder (cell r <$> [0..3])) + contentSample = " 2048 " :: String + hMax = length contentSample + cell :: Int -> Int -> Widget RName + cell r c = + vLimit 1 . hLimit hMax $ cellW + where + val = bd !! r !! c + cellW = + if val == 0 + then fill ' ' + else + withAttr (tierAttr . valToTier $ val) + . padLeft Max + $ str (show (bd !! r !! c) <> " ") + +ui :: AppState -> Widget RName +ui s@(bd,score) = + center $ + hCenter (boardWidget s) + <=> hCenter (str $ "Current Score: " <> show score) + <=> hCenter (str ctrlHelpMsg) + where + GS {hasWon, isAlive} = gameState bd + moveHelp = "i / k / j / l / arrow keys to move, " + commonHelp = "q to quit, r to restart." + {- TODO: this starts getting awkward, perhaps time to split the widget. -} + ctrlHelpMsg = + if not isAlive + then + (if hasWon then "You won, but no more moves. " else "No more moves, game over. ") + <> commonHelp + else + (if hasWon then "You've won! " else "") + <> moveHelp <> commonHelp + +handleEvent :: AppState -> BrickEvent RName e -> EventM RName (Next AppState) +handleEvent s@(bd,score) e = case e of + VtyEvent (EvKey (KChar 'q') []) -> halt s + VtyEvent (EvKey (KChar 'r') []) -> + liftIO initGameBoard >>= continue + VtyEvent (EvKey k []) + | Just dir <- getMove k -> case updateBoard dir bd of + Nothing -> continue s + Just (bd', awarded) -> do + bd'' <- fromJust <$> liftIO (insertNewCell bd') + continue (bd'', score+awarded) + _ -> continue s + +getMove :: Key -> Maybe Dir +getMove KUp = Just DUp +getMove KDown = Just DDown +getMove KLeft = Just DLeft +getMove KRight = Just DRight +getMove (KChar 'i') = Just DUp +getMove (KChar 'k') = Just DDown +getMove (KChar 'j') = Just DLeft +getMove (KChar 'l') = Just DRight +getMove _ = Nothing + +main :: IO () +main = do + initGb <- initGameBoard + let app = + App + { appDraw = \s -> [ui s] + , appHandleEvent = handleEvent + , appStartEvent = pure + , appAttrMap = + const $ + attrMap defAttr $ + zip (tierAttr <$> [1..]) + [ fg (ISOColor 7) `withStyle` dim + , fg (ISOColor 6) `withStyle` dim + , fg (ISOColor 3) `withStyle` dim + , fg (ISOColor 2) `withStyle` dim + , fg (ISOColor 1) `withStyle` dim + , fg (ISOColor 7) `withStyle` bold + , fg (ISOColor 4) `withStyle` bold + , fg (ISOColor 6) `withStyle` bold + , fg (ISOColor 2) `withStyle` bold + , fg (ISOColor 1) `withStyle` bold + , fg (ISOColor 3) `withStyle` bold + ] + , appChooseCursor = neverShowCursor + } + initState = initGb + void $ defaultMain app initState diff --git a/src/Game/H2048/UI/Simple.hs b/src/Game/H2048/UI/Simple.hs --- a/src/Game/H2048/UI/Simple.hs +++ b/src/Game/H2048/UI/Simple.hs @@ -9,19 +9,22 @@ A simple CLI implemention of Game 2048 -} +{-# LANGUAGE NamedFieldPuns #-} module Game.H2048.UI.Simple - ( drawBoard - , playGame - , mainSimple - ) + ( drawBoard + , playGame + , main + , Board + ) where +import Data.Maybe import Game.H2048.Core - import Data.List import Text.Printf import Control.Monad.IO.Class import Control.Monad.Random +import Control.Applicative import Control.Arrow import System.IO @@ -33,9 +36,9 @@ -- | pretty print the board to stdout drawBoard :: Board -> IO () -drawBoard board = do +drawBoard bd = {- - when outputed, a cell will look like: + a cell will be represented in the output as following: +-----+ | xxx | @@ -48,112 +51,96 @@ * 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 + putStrLn horizSeparator >> + mapM_ drawRow (fromBoard bd) + where + cellWidth = length " 2048 " + -- build up the separator: "+--+--+....+" + horizSeparator' = intercalate "+" (replicate 4 (replicate cellWidth '-')) + horizSeparator = "+" ++ horizSeparator' ++ "+" - drawRow :: [Int] -> IO () - drawRow row = do - -- prints "| | | ... |" - putChar '|' - mapM_ (prettyCell >>> putStr >>> (>> putChar '|') ) row - putChar '\n' - putStrLn horizSeparator + -- pretty string for a cell (without border) + prettyCell c = + if c == 0 + then replicate cellWidth ' ' + else printf " %4d " c + + 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 +playGame :: (MonadIO m, MonadRandom m, Alternative m) => (Board, Int) -> m () +playGame args@(b,score) | + GS {hasWon, isAlive} <- gameState b = + if isAlive + then liftIO (handleUserMove hasWon) >>= handleGame + else liftIO (endGame args hasWon) + where + endGame (b',score') win = do + drawBoard b' + putStrLn $ if win then "You won" 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 w = fix $ \self -> do + let scoreFormat = + if w + 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 + case c of + 'q' -> pure Nothing + 'i' -> putStrLn "Up" >> pure (Just DUp) + 'k' -> putStrLn "Down" >> pure (Just DDown) + 'j' -> putStrLn "Left" >> pure (Just DLeft) + 'l' -> putStrLn "Right" >> pure (Just DRight) + _ -> do + -- user will not be on this branch + -- if an invalid key is pressed + putStrLn helpString + self + handleGame = + maybe + -- user quit + (pure ()) + -- 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 args) + -- 2(b). on success, insert new cell + (\(newBoard, scoreObtained) -> do + -- should always succeed + -- because when a successful move is done + -- there is at least one empty cell in the board + newB <- fromJust <$> insertNewCell newBoard + -- keep going, accumulate score + playGame (newB, score + scoreObtained))) -- | the entry of Simple UI -mainSimple :: IO () -mainSimple = do +main :: IO () +main = 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 + -- show some helpful messages + -- whether the user has read the README or not :) putStrLn helpString -- initialize game based on the random seed _ <- evalRandT (initGameBoard >>= playGame) g diff --git a/src/Game/H2048/UI/Vty.hs b/src/Game/H2048/UI/Vty.hs deleted file mode 100644 --- a/src/Game/H2048/UI/Vty.hs +++ /dev/null @@ -1,207 +0,0 @@ -{-| - 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 - KChar 'q' -> - shutdownUi >> return True - KChar 'i' -> - doUpdate DUp - KUp -> - doUpdate DUp - KChar 'k' -> - doUpdate DDown - KDown -> - doUpdate DDown - KChar 'j' -> - doUpdate DLeft - KLeft -> - doUpdate DLeft - KChar '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 --- a/src/Game/H2048/Utils.hs +++ b/src/Game/H2048/Utils.hs @@ -10,16 +10,11 @@ -} module Game.H2048.Utils - ( inPos - , universe - ) + ( inPos + ) where --- provide utilities - --- | all possible values for a Bounded Enum -universe :: (Bounded e, Enum e) => [e] -universe = [minBound .. maxBound] +import Control.Lens -- | modify a specified element in a list, -- this is a simple semantic editor combinator @@ -27,12 +22,4 @@ -> (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 +inPos n = over (ix n) diff --git a/src/MainSimple.hs b/src/MainSimple.hs deleted file mode 100644 --- a/src/MainSimple.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Main -where - -import Game.H2048.UI.Simple - -main :: IO () -main = mainSimple diff --git a/src/MainVty.hs b/src/MainVty.hs deleted file mode 100644 --- a/src/MainVty.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Main -where - -import Game.H2048.UI.Vty - -main :: IO () -main = mainVty diff --git a/src/Test.hs b/src/Test.hs deleted file mode 100644 --- a/src/Test.hs +++ /dev/null @@ -1,88 +0,0 @@ -import Test.HUnit - -import Control.Arrow -import Control.Monad -import Control.Monad.Writer -import System.Exit - -import Game.H2048.Core - --- | the expected behavior of 'compactLine' -compactLineTestcases :: [ ((Line, Int) , Line) ] -compactLineTestcases = - -- < expected > < input > - [ ( ([0,0,0,0],0), [0,0,0,0] ) - , ( ([2,0,0,0],2), [1,0,0,1] ) - , ( ([4,4,0,0],8), [2,2,2,2] ) - , ( ([2,8,2,0],8), [2,4,4,2] ) - , ( ([2,4,8,2],0), [2,4,8,2] ) - , ( ([2,0,0,0],2), [0,1,0,1] ) - , ( ([1,2,0,0],0), [1,0,2,0] ) - ] - -compactLineTests :: Test -compactLineTests = TestLabel "compactLine" . TestList . map - (\(expected, inp) -> - expected ~=? - second getSum (runWriter (compactLine inp))) - $ compactLineTestcases - --- | the expected behavior of 'gameState' -gameStateTestcases :: [ (String, GameState, Board) ] -gameStateTestcases = - [ ( "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 ] ] ) - , ( "no more move but win", - 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 ] ] ) - , ( "no empty cell but still alive", - 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 ] ] ) - , ( "trivial lose 2", - Lose , [ [ 2, 8, 32, 2 ] - , [ 4, 2, 8, 4 ] - , [ 32, 16, 128, 16 ] - , [ 4, 8, 4, 2 ] ] ) - ] - -gameStateTests :: Test -gameStateTests = TestLabel "gameState" . TestList . map - (\(lbl, expected, inp) -> - TestLabel lbl (expected ~=? gameState inp)) - $ gameStateTestcases - --- | run testcase and quit immediately after a failure -runTestFailIm :: Test -> IO () -runTestFailIm t = do - cs <- runTestTT t - print cs - when (errors cs > 0 || failures cs > 0) - exitFailure - -main :: IO () -main = mapM_ runTestFailIm - [ compactLineTests - , gameStateTests - ] diff --git a/test/Game/H2048/CoreSpec.hs b/test/Game/H2048/CoreSpec.hs new file mode 100644 --- /dev/null +++ b/test/Game/H2048/CoreSpec.hs @@ -0,0 +1,78 @@ +module Game.H2048.CoreSpec where + +import Test.Hspec + +import Game.H2048.Core + +spec :: Spec +spec = do + describe "compactLine" $ + specify "examples" $ do + let clTest inp expected = + compactLine' (mkLine inp) + `shouldBe` (eScore, mkLine eLine) + where + (eScore, eLine) = expected + clTest [0,0,0,0] (0,[0,0,0,0]) + clTest [1,0,0,1] (2,[2,0,0,0]) + clTest [2,2,2,2] (8,[4,4,0,0]) + clTest [2,4,4,2] (8,[2,8,2,0]) + clTest [2,4,8,2] (0,[2,4,8,2]) + clTest [0,1,0,1] (2,[2,0,0,0]) + clTest [1,0,2,0] (0,[1,2,0,0]) + + describe "gameState" $ do + let gWonAlive = GS True True + gWon = GS True False + gAlive = GS False True + gLose = GS False False + gameState' = gameState . mkBoard + specify "trivial win, alive" $ + gameState' + [ [ 2048, 2048, 2048, 2048 ] + , [ 0, 0, 0, 0 ] + , [ 0, 0, 0, 0 ] + , [ 0, 0, 0, 0 ] + ] `shouldBe` gWonAlive + specify "more than 2048 (might not happen in practice)" $ + gameState' + [ [ 256, 2, 4, 8 ] + , [ 16, 32, 64, 128 ] + , [ 256, 512, 1024, 8 ] + , [ 16, 4096, 128, 64 ] + ] `shouldBe` gWon + specify "no more move but win" $ + gameState' + [ [ 2, 4, 2, 4 ] + , [ 4, 2048, 4, 2 ] + , [ 2, 4, 2, 4 ] + , [ 4, 2, 4, 2 ] + ] `shouldBe` gWon + specify "trivial alive" $ + gameState' + [ [ 2, 0, 0, 8 ] + , [ 4, 0, 0, 8 ] + , [ 4, 0, 0, 8 ] + , [ 1024, 512, 128, 64 ] + ] `shouldBe` gAlive + specify "no empty cell but still alive" $ + gameState' + [ [ 512, 128, 512, 128 ] + , [ 128, 512, 128, 512 ] + , [ 512, 128, 512, 128 ] + , [ 128, 512, 128, 128 ] + ] `shouldBe` gAlive + specify "trivial lose 1" $ + gameState' + [ [ 2, 4, 2, 4 ] + , [ 4, 2, 4, 2 ] + , [ 2, 4, 2, 4 ] + , [ 4, 2, 4, 2 ] + ] `shouldBe` gLose + specify "trivial lose 2" $ + gameState' + [ [ 2, 8, 32, 2 ] + , [ 4, 2, 8, 4 ] + , [ 32, 16, 128, 16 ] + , [ 4, 8, 4, 2 ] + ] `shouldBe` gLose diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}