diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,14 +1,15 @@ -# 1.0.0.0 (pending) +# 0.3.0.0 -- scrap direct `vty` support due to its deprecation. +- Replace `vty-ui` support with `brick` due to the deprecation of the former. +- Remove flags as they do not appear to be very useful. # 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/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,24 +4,37 @@ 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) +* a library for experimenting game strategies for Game 2048. +* a simple program that provides the basic interaction with the game. +* a CUI implemented using [brick](http://hackage.haskell.org/package/brick). Based on [2048](https://github.com/gabrielecirulli/2048) # Screenshots -## Simple CLI version +## Simple version -![](http://i.imgur.com/FS3tdLp.jpg) +![](https://raw.githubusercontent.com/Javran/h2048/master/doc/simple.jpg) -## vty CLI version +## brick-based version -![](http://i.imgur.com/twNDMeq.jpg) +![](https://raw.githubusercontent.com/Javran/h2048/master/doc/brick.jpg) ## Build and run +### With stack + +h2048 comes with [stack](https://docs.haskellstack.org/en/stable/README/) configuration, +if you are building from source code, change directory to the project root and run: + +```bash +stack build +# to run the brick version +stack exec -- h2048-brick +# to run the simple version +stack exec -- h2048-simple +``` + ### With cabal `h2048` is now available on [hackage](http://hackage.haskell.org/package/h2048). @@ -29,48 +42,13 @@ If you have [Cabal](http://www.haskell.org/cabal/) installed, you can use the following command to install this project: - cabal update - cabal install h2048 - -The binaries are `h2048-simple` for simple CLI version, `h2048-vty` for CLI version -implemented using `vty-ui`. - -### Flags - -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`. - -An example for turning off flag `vty`: - - # 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 - -### Without cabal - -First make sure the following dependencies are installed: - -* [transformers](http://hackage.haskell.org/package/transformers) -* [mtl](http://hackage.haskell.org/package/mtl) -* [MonadRandom](http://hackage.haskell.org/package/MonadRandom) - -In addition, if you want to play with vty CLI version, the following dependencies -are also required: - -* [text](http://hackage.haskell.org/package/text) -* [vty](http://hackage.haskell.org/package/vty) -* [vty-ui](http://hackage.haskell.org/package/vty-ui) - -You can use following commands to run the program without cabal: +```bash +cabal update +cabal install h2048 +``` - cd src # assume your working directory is the project home. - # to play the simple CLI version - runhaskell MainSimple.hs - # to play the vty CLI version - runhaskell MainVty.hs +The binaries are `h2048-simple` for simple CUI version, `h2048-brick` for CUI version +implemented using `brick`. ## How to play @@ -82,4 +60,4 @@ * `j`: left * `l`: right -If you are using `h2048-vty`, you can also use arrow keys. +If you are using `h2048-brick`, you can also use arrow keys. diff --git a/h2048.cabal b/h2048.cabal --- a/h2048.cabal +++ b/h2048.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 name: h2048 -version: 0.3.0.0 +version: 0.4.0.0 license: MIT license-file: LICENSE maintainer: Javran.C@gmail.com @@ -23,20 +23,22 @@ library exposed-modules: Game.H2048.Core + Game.H2048.Gameplay 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, + containers >=0.6.0.1 && <0.7, mtl >=2.2.2 && <2.3, text >=1.2.3.1 && <1.3, + tf-random ==0.5.*, + vector >=0.12.0.3 && <0.13, + vector-algorithms >=0.8.0.1 && <0.9, vty >=5.25.1 && <5.26 executable h2048-brick @@ -49,13 +51,15 @@ 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, + containers >=0.6.0.1 && <0.7, h2048 -any, - lens >=4.17.1 && <4.18, mtl >=2.2.2 && <2.3, text >=1.2.3.1 && <1.3, + tf-random ==0.5.*, + vector >=0.12.0.3 && <0.13, + vector-algorithms >=0.8.0.1 && <0.9, vty >=5.25.1 && <5.26 executable h2048-simple @@ -68,13 +72,15 @@ 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, + containers >=0.6.0.1 && <0.7, h2048 -any, - lens >=4.17.1 && <4.18, mtl >=2.2.2 && <2.3, text >=1.2.3.1 && <1.3, + tf-random ==0.5.*, + vector >=0.12.0.3 && <0.13, + vector-algorithms >=0.8.0.1 && <0.9, vty >=5.25.1 && <5.26 test-suite hspec @@ -83,16 +89,19 @@ hs-source-dirs: test other-modules: Game.H2048.CoreSpec + Game.H2048.GameplaySpec 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, + containers >=0.6.0.1 && <0.7, 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, + tf-random ==0.5.*, + vector >=0.12.0.3 && <0.13, + vector-algorithms >=0.8.0.1 && <0.9, 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 @@ -1,130 +1,260 @@ +{-# LANGUAGE + MonadComprehensions + , TupleSections + , LambdaCase + #-} {-| - Module : Game.H2048.Core - Copyright : (c) 2014 Javran Cheng - License : MIT - Maintainer : Javran.C@gmail.com - Stability : experimental - Portability : POSIX + This module is considered internal. + Clients should use "Game.H2048.Gameplay" instead. + -} +module Game.H2048.Core + ( Coord + , Coords + , CoordsGroup + , Dir(..) + , CellTier + , Cell(..) + , Distrib' + , Distrib + , GameRule(..) + , GameBoard + , randomPick + , allCoords + , applyMove + , possibleMoves + , unsafeIntToCell + , intToCell + , cellToInt + , standardGameRule + , merge + , mergeWithScore + , mergeLine + , dirToCoordsGroups + , computeDistrib + , testDistrib + , isAlive + ) where -The core game logic implementation for Game 2048. +import Control.Monad.ST +import Control.Monad.State +import Data.Bifunctor +import Data.Bits +import Data.Maybe +import Data.Monoid +import Data.Ord +import Data.Tuple +import System.Random.TF +import System.Random.TF.Instances -The routine for using this library would be: +import qualified Data.IntMap.Strict as IM +import qualified Data.Map.Strict as M +import qualified Data.Vector as V +import qualified Data.Vector.Algorithms.Search as VA -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. + Note that this module should be considered internal, and only imported + by Game.H2048.Gameplay or unit test modules. -3. use `insertNewCell` to insert a new cell randomly + This is an overhaul and improvement of the old Game.H2048.Core module. -4. examine if the player wins / loses / is still alive using `gameState`. + Differences are: --} -{-# LANGUAGE TupleSections, FlexibleContexts, RankNTypes #-} -module Game.H2048.Core - ( Dir (..) - , BoardUpdateResult - , Board - , mkBoard - , fromBoard - , defBoard - , Line - , mkLine - , defLine - , gameState - , GameState(..) - , compactLine' - , compactLine - , initGameBoard - , updateBoard - , insertNewCell - , nextMoves - ) -where + - Board is Map-based rather than any linear structure. -import Data.List -import Data.Maybe +This makes it convenient to change values or scale to support non-standard grid + (i.e. any board other than 4x4) -import Control.Applicative -import Control.Monad.Writer -import Control.Monad.Random -import Data.Coerce -import Control.Lens + - Use a newtype Cell = Cell Int to define tiers rather than using powers of 2. + This results in a compact representation of the board, and this also allows + separating how data are displayed and how data are represented - you can + use powers of two or some English words, which has no effect on the core itself. -import Game.H2048.Utils + - Use tf-random for better random number generation. --- | represent a 4x4 board for Game 2048 --- each element should be either zero or 2^i --- where i >= 1. -newtype Board = Board [Line] + - Less verbosity on API. This module is now an internal one that only implements + some key operations and all of the rest are implemented or re-exported through + Game.H2048.Gameplay. This minimized the code for game logic on client side. -data GameState = GS - { hasWon :: Bool - , isAlive :: Bool - } deriving (Eq, Show) + - A GameRule data type for customizing game rules. -{- - 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... +{-| + A `CellTier` is simply a positive `Int`. Every time two cell merges, + the tier of the resulting cell increases by one relative to cell tier + prior to the merge. -} -mkBoard :: [[Int]] -> Board -mkBoard = Board . take 4 . (++ repeat defLine) . (mkLine <$>) +type CellTier = Int -fromBoard :: Board -> [[Int]] -fromBoard = coerce +{-| + An obscure data type that wraps 'CellTier'. + -} +newtype Cell = + Cell + { _cTier :: CellTier -- ^ Tier of this cell. + } deriving (Eq, Ord, Show) --- | a list of 4 elements, stands for --- one column / row in the board -{- - 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. +{-| + Convert an integer to 'Cell', the input is expected + to be a power of 2 but no check is enforced. - 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) + Given that standard game is based on powers of 2, it makes sense + that we implement some direct support for it. + -} +unsafeIntToCell :: Int -> Cell +unsafeIntToCell = Cell . countTrailingZeros -mkLine :: [Int] -> Line -mkLine = Line . take 4 . (++ repeat 0) +{-| + Safely convert a power of two into 'Cell'. + -} +intToCell :: Int -> Maybe Cell +intToCell v = [ unsafeIntToCell v | v > 0, popCount v == 1 ] -defLine :: Line -defLine = mkLine [] +{-| + Convert 'Cell' back into a power of 2. + -} +cellToInt :: Cell -> Int +cellToInt (Cell t) = shiftL 1 t --- | result after a successful 'updateBoard' -type BoardUpdateResult = (Board, Int) +{-| + Attempt to merge two 'Cell' s. + Only successful when two `Cell`s are equal, resulting in a new Cell + with tier increased by 1. + -} +merge :: Cell -> Cell -> Maybe Cell +merge (Cell a) (Cell b) = [ Cell (succ a) | a == b ] + +{-| + Zero-based @(rowIndex, colIndex)@. + -} +type Coord = (Int, Int) + +{-| + A 'GameBoard' is a map from coordinates to 'Cell's for a game. + + Note that the map could be empty to indicate that + a new game is not started yet. + -} +type GameBoard = M.Map Coord Cell + +{-| + The same as 'Distrib' except parameterized on the value type. + -} +type Distrib' a = V.Vector (a, Int) + +{-| + A 'Distrib' is a non-empty 'V.Vector' whose each element @(a,b)@ satisfies: + + * @a@, when taken in sequence, is positive and strictly increasing. + * @b@, when taken in sequence, is strictly increasing. + + Think this data type as a precomputation result for + making weighted random choice. + + You can use 'computeDistrib' to generate a value of this. + -} +type Distrib = Distrib' Int + +{-| + A data type for encoding game rules that do not necessarily + needs to be hard-coded into core logic. + + You can use 'standardGameRule' for a standard game rule, + or make changes using it as the base. + -} +data GameRule + = GameRule + { {-| + Dimension of the board. @(numOfRows, numOfCols)@ + -} + _grDim :: (Int, Int) + {-| + Score awarded given 'CellTier' /before/ the merge has happened. + -} + , _grMergeAward :: CellTier -> Int + {-| + Stores precomputation result that encodes distribution of tiers + of newly spawned cells. + -} + , _grNewCellDistrib :: Distrib + {-| + How many initial cells should be spawned when starting the game. + + Note this value should not exceed number of cells that the board can contain. + -} + , _grInitSpawn :: Int + {-| + A predicate to tell whether the current game has been won. + -} + {- + Some extra notes for those that want to read a bit more: + + Notice that this core logic only cares about whether we have valid moves + on a GameBoard (see also 'isAlive' below) but does not use '_grHasWon' at all. + + In fact, in the standard game rule, whether we are winning and whether we have + valid moves are sort of independent of each other. + This means we can minimize core logic by letting client-facing API module + take responsibility for handling the winning logic. + + Despite not being used by core, we still keep it here, because: + + * it makes sense as GameRule is literally the set of things that dictates the gameplay. + * modules that implements things on top of this core don't need to + add another layer of data type to include extra stuff that they would need. + -} + , _grHasWon :: Int -> GameBoard -> Bool + } + +{-| + The standard game rule. This value can be used as a base + for customized game rules. + -} +standardGameRule :: GameRule +standardGameRule = GameRule + { _grDim = (4,4) + , _grInitSpawn = 2 + , _grNewCellDistrib = computeDistrib $ IM.fromList [(1, 9), (2, 1)] + , _grHasWon = \_score -> + let c2048 = unsafeIntToCell 2048 + in any (>= c2048) + , _grMergeAward = \prevTier -> shiftL 1 (prevTier+1) -- 2^(prevTier+1) + } + +{-| + Merge two cells with a reward as specified by 'GameRule'. + -} +mergeWithScore :: GameRule -> Cell -> Cell -> Maybe (Cell, Int) +mergeWithScore gr a b = do + let Cell ctPrev = a + c <- merge a b + pure (c, _grMergeAward gr ctPrev) + +{-| + Merge a single line of cells, return the resulting line and + scores awarded according to the 'GameRule'. + -} {- - 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. + Notice that input and output are both lists: - therefore we could probably return a list of pairs of - (, [Cell] -> ([Cell], Int) +mergeLine gr = mergeLine' 0 + where + mergeLine' acc xs = case xs of + a:b:ys + | Just (c, award) <- mergeWithScore gr a b -> + first (c:) $ mergeLine' (acc+award) ys + a:ys -> first (a:) (mergeLine' acc ys) + [] -> ([], acc) --- | move direction +-- | Moves that a user could do. data Dir = DUp | DDown @@ -132,123 +262,173 @@ | DRight deriving (Enum, Bounded, Eq, Ord, Show) -allDirs :: [Dir] -allDirs = [minBound .. maxBound] +{-| + List of 'Coord'. This list + is usually a complete row or column in the game board. + -} +type Coords = [Coord] --- | the initial board before a game started -defBoard :: Board -defBoard = mkBoard [] +{-| + List of 'Coords', expected to exact-cover the game board. + -} +type CoordsGroup = [Coords] -compactLine' :: Line -> (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 +{-| + Given a game move, + return rows or columns of 'Coords' that forms the complete board. + -} +dirToCoordsGroups :: GameRule -> Dir -> CoordsGroup +dirToCoordsGroups gr = \case + DUp -> do + c <- [0..cols-1] + pure $ (,c) <$> [0..rows-1] + DDown -> do + c <- [0..cols-1] + pure $ (,c) <$> [rows-1,rows-2..0] + DLeft -> do + r <- [0..rows-1] + pure $ (r,) <$> [0..cols-1] + DRight -> do + r <- [0..rows-1] + pure $ (r,) <$> [cols-1,cols-2..0] + where + (rows, cols) = _grDim gr --- | move each non-zero element to their leftmost possible --- position while preserving the order -compactLine :: MonadWriter (Sum Int) m => Line -> m Line -compactLine l = let (v, l') = compactLine' l in writer (l', v) +{-| + Retrieve a list of cells from game board. + This operation preserves order. Empty cells are excluded from the result. + -} +extractByCoords :: GameBoard -> [Coord] -> [Cell] +extractByCoords bd = mapMaybe (bd M.!?) --- | update the board taking a direction, --- a 'BoardUpdated' is returned on success, --- if this update does nothing, that means a failure (Nothing) --- 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) +{-| + Return a unique, sorted list of all coordinations of a board. + -} +allCoords :: GameRule -> Coords +allCoords GameRule { _grDim = (rowCnt, colCnt) } = + [ (r,c) | r <- [0..rowCnt-1], c <- [0..colCnt-1] ] -getIso :: Dir -> Iso' [Line] [Line] -getIso d = c . ik . from c +alterCoordsOnBoard :: [Coord] -> [Cell] -> GameBoard -> GameBoard +alterCoordsOnBoard coords vals = + appEndo (foldMap (Endo . alterBoard) (zip coords mVals)) where - ik = case d of - DLeft -> id - DRight -> sRight - DUp -> sUp - DDown -> sRight . sUp - c :: Iso' [Line] [[Int]] - c = coerced + {- + Note the use of "M.alter" here - we need to do insertion and deletion + at the same time and M.alter does just that. - sRight = involuted (map reverse) - sUp = involuted transpose + Also note that "M.update" cannot be used here because it does not insert if missing. -nextMoves :: Board -> [(Dir, BoardUpdateResult)] -nextMoves b = mapMaybe (\d -> (d,) <$> updateBoard d b) allDirs + Also coords should all be distinct, so it does not matter + the order that this sequence of updates are performed. + -} + alterBoard (coord, mVal) = M.alter (const mVal) coord + mVals = (Just <$> vals) <> repeat Nothing --- | find blank cells in a board, --- return coordinates for each blank cell -blankCells :: Board -> [(Int, Int)] -blankCells (Board b) = map (\(row, (col, _)) -> (row,col)) blankCells' +{-| + Apply a game move on certain part of the board specified by @Coords@. + -} +applyMoveOnCoords :: GameRule -> Coords -> GameBoard -> (GameBoard, Int) +applyMoveOnCoords gr coords bd = + (alterCoordsOnBoard coords cells' bd, score) where + cells = extractByCoords bd coords + (cells', score) = mergeLine gr cells + +{-| + Apply a game move on a board. + This operation fails if and only if the move results in no change to the game board. + -} +applyMove :: GameRule -> Dir -> GameBoard -> Maybe (GameBoard, Int) +applyMove gr dir bd = {- - 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" + Note that a GameBoard could be empty to indicate that it is uninitialized, + in which case every move will fail because no change on the board could be made. -} - blankCells' = filter ((== 0) . snd . snd) linearBoard - -- flatten to make it ready for filter - linearBoard = concat $ zipWith tagRow [0..] colTagged + [ (bd', score) | bd /= bd' ] + where + csGroups = dirToCoordsGroups gr dir + (scores, bd') = + runState + (mapM (\coords -> state (swap . applyMoveOnCoords gr coords)) csGroups) + bd + score = sum (scores :: [Int]) - -- tag cells with row num - tagRow row = map (row,) - -- tag cells with column num - colTagged = map (zip [0..] . (coerce :: Line -> [Int])) b +{-| + Return possible moves that can be performed on current board. + -} +possibleMoves :: GameRule -> GameBoard -> [(Dir, (GameBoard, Int))] +possibleMoves gr bd = + mapMaybe (\d -> (d,) <$> applyMove gr d bd) [minBound .. maxBound] -gameState :: Board -> GameState -gameState nb@(Board b) = GS hw alv +{- + Pre-processing the distribution: + + e.g. {a: 3, b: 4, c: 2} + => [(a, 3), (b, 3+4), (c, 3+4+2)] = [(a, 3), (b, 7), (c, 9)] + + after this is done, we can pick a value + from 1 to the last element of this vector (in this case, 9.), + and lookup the corresponding element. + + -} +{-| + Computes `Distrib` for weighted random cell tier spawns. + + The input must be a non-empty map from cell tiers to their + corresponding weight. All weights must be positive. + -} +computeDistrib :: IM.IntMap Int -> Distrib +computeDistrib m = + V.fromListN (IM.size m) $ zip (fmap fst pairs) weights where - hw = (any (>= 2048) . concatMap (coerce :: Line -> [Int])) b - alv = not . null . nextMoves $ nb + pairs = IM.toList m + weights = scanl1 (+) . fmap snd $ pairs --- | initialize the board by puting two cells randomly --- into the board. --- See 'generateNewCell' for the cell generating rule. -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 - (,0) . fromJust <$> (insertNewCell defBoard >>= (insertNewCell . fromJust)) +{-| + Pick a value randomly following the distribution as specified by the argument. + -} +randomPick :: Distrib' a -> TFGen -> (a, TFGen) +randomPick vec g = runST $ do + let upper = snd (V.last vec) + (val, g') = randomR (1, upper) g + -- safe because binary search is read-only. + mv <- V.unsafeThaw vec + {- + Say if the accumulated distribution is like: --- | try to insert a new cell randomly -insertNewCell :: (MonadRandom r, Alternative r) => Board -> r (Maybe Board) -insertNewCell b = do - -- get a list of coordinates of blank cells - let availableCells = blankCells 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' + > [1,3,5] --- | 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 = getRandom >>= \r -> - pure $ if r < (0.9 :: Float) then 2 else 4 + Given 3, valid insertion points are: + + > [1,3,5] + ^ ^ + But in our case we really want the lowest one, therefore using binarySearchLBy. + -} + ind <- VA.binarySearchLBy (comparing snd) mv (error "unused", val) + pure (fst (vec V.! ind), g') + +{-| + Repeat the process of randomly picking elements following a distribution in @IO@. + + This function is exported just for manual testing. + -} +testDistrib :: Int -> [(Int, Int)] -> IO () +testDistrib count xs = do + let d = computeDistrib (IM.fromList xs) + g <- newTFGen + let picks = + IM.fromListWith (+) + . fmap (,1 :: Int) + . evalState (replicateM count (state (randomPick d))) + $ g + mapM_ print (IM.toAscList picks) + +{-| + A current game is consider \"alive\" when there are at least one + valid move for the current board. + + Note that since a GameBoard can be newly initiate as empty Map, + it is not \"alive\" by definition. + -} +isAlive :: GameRule -> GameBoard -> Bool +isAlive gr bd = not . null $ possibleMoves gr bd diff --git a/src/Game/H2048/Gameplay.hs b/src/Game/H2048/Gameplay.hs new file mode 100644 --- /dev/null +++ b/src/Game/H2048/Gameplay.hs @@ -0,0 +1,194 @@ +{-| + Game implementation on top of "Game.H2048.Core". + This module is formally the API for this package, + please avoid using "Game.H2048.Core" directly if possible. + -} +module Game.H2048.Gameplay + ( Gameplay + , _gpRule + , _gpScore + , _gpBoard + , _gpGen + , randomOp + , mkGameplay + , spawnNewCell + , GameBoard + , CellTier + , Cell + , _cTier + , Dir(..) + , Distrib + , GameRule(..) + , newGame + , stepGame + , standardGameRule + , hasWon + , isAlive + , cellToInt + , intToCell + , computeDistrib + ) where + +import Control.Monad.RWS.Strict +import System.Random.TF +import System.Random.TF.Instances + +import qualified Data.Map.Strict as M +import qualified Data.Set as S + +import Game.H2048.Core hiding (isAlive) +import qualified Game.H2048.Core as Core + +{- + Some quick note: I originally thought http://hackage.haskell.org/package/monad-control + might offer some nice tools that allows us to turn the stack of monad transformers into + a base monad with the stack encoded, but actually it doesn't help much + in this case: we've all known monad cannot be escaped without magic, even if + we somehow get a base monad back, it's still packed within current monad, + not very helpful. + + In addition, monad-control seems to encode MonadReader by ignoring its environment. + I can understand this design choice but this also means we need to pass the environment + as argument when we recover the transformer stack - so in conclusion, I still think + current implementation is good enough. + -} + +{-| + A 'Gameplay' is an obscure data type to keep track of information necessary + for a single game play. Its fields can be accessed through functions + with @_gp@ prefix. + -} +data Gameplay + = Gameplay + { + -- | Encodes rule of this game. This field must not change after creation. + _gpRule :: GameRule + -- | Total score currently collected. + , _gpScore :: Int + {-| + The Game board. If this field is an empty map, + that means the game is not yet started. + -} + , _gpBoard :: GameBoard + -- | Random generator. + , _gpGen :: TFGen + } + +{-| + Lift a function that mutates a 'TFGen' to produce some results to + work on 'Gameplay'. + -} +randomOp :: (TFGen -> (a, TFGen)) -> Gameplay -> (a, Gameplay) +randomOp op gp = (v, gp { _gpGen = g' }) + where + g = _gpGen gp + (v, g') = op g + +{-| + Create a 'Gameplay'. Note that the return value must be passed to 'newGame' + before it can accept any game moves. + + The purpose of this two-step approach (i.e. 'mkGameplay' then 'newGame') is + to separate data type creation from the effect of mutating random generator, + which is required at the beginning of a game. + -} +mkGameplay :: TFGen -> GameRule -> Gameplay +mkGameplay g r = + Gameplay + r + 0 + M.empty -- default board is empty - no move is allowed on it. + g + +{-| + @spawnNewCell gameplay emptyCells@ picks an empty cell from @emptyCells@, + and assign it with a cell value. The operation will fail if and only if + @emptyCells@ is empty. + + Upon successful return, the value wrapped in @Just@ is + @(sepResult, gameplay')@ where @sepResult@ indicates coordinate and cell value + chosen, and remaining part of @emptyCells@. + + The reason for explicitly passing @emptyCells@ on this operation + is to make it easier to pick multiple cells while not touching most parts of 'Gameplay'. + In fact you can expect this operation to only mutate the 'TFGen' inside 'Gameplay'. + -} +spawnNewCell :: Gameplay -> S.Set Coord -> Maybe (((Coord, Cell), S.Set Coord), Gameplay) +spawnNewCell gp emptyCells = do + False <- pure $ S.null emptyCells + let -- step 1: pick an empty cell. + lowHigh = (0, S.size emptyCells - 1) + (i, gp') = randomOp (randomR lowHigh) gp + v = S.toAscList emptyCells !! i + -- step 2: pick a tier. + distrib = _grNewCellDistrib . _gpRule $ gp' + (tier, gp'') = randomOp (randomPick distrib) gp' + pure (((v, Cell tier), S.delete v emptyCells), gp'') + +{-| + Initialize a 'Gameplay' so that it\'s ready to play. + + This function should only fail when its 'GameRule' dictates too many + initial cells for the whole board to contain. + -} +newGame :: Gameplay -> Gameplay +newGame gp = + fix (\loop curGp spawnTodo emptyCells -> + if spawnTodo <= 0 + then curGp + else case spawnNewCell curGp emptyCells of + Nothing -> + error "Failed to create new game, no more space for empty cells." + Just (((coord, cell), emptyCells'), curGp') -> + let curGp'' = curGp' { _gpBoard = M.insert coord cell (_gpBoard curGp') } + in loop curGp'' (spawnTodo - 1) emptyCells' + ) + (gp { _gpScore = 0 }) + initSpawn + (S.fromDistinctAscList coords) + where + rule = _gpRule gp + coords = allCoords rule + initSpawn = _grInitSpawn rule + +{-| + @stepGame d gp@ tries to apply move @d@ on current state of the game @gp@, returns: + + * @Nothing@ if this move is invalid (failed to apply the move). + * @Just moves@ if this move is valid, also returns all possible moves + after the board is fully updated (meaning new cell has been spawned). + -} +stepGame :: Dir -> Gameplay -> Maybe Gameplay +stepGame dir gp = do + let rule = _gpRule gp + coords = allCoords rule + bd = _gpBoard gp + {- + if a move can be applied successfully, that means + there must be empty cell on the board, + in other words, spawnNewCell should not fail. + -} + (bd', award) <- applyMove rule dir bd + let emptyCoords = S.filter (`M.notMember` bd') (S.fromDistinctAscList coords) + (((coordNew, cellNew), _), gp') <- spawnNewCell gp emptyCoords + pure gp' + { _gpBoard = M.insert coordNew cellNew bd' + {- + This assumes that spawnNewCell does not change _gpScore, + otherwise whatever update will be overwritten by following one. + -} + , _gpScore = _gpScore gp + award + } + +{-| + A 'Gameplay' is considered alive if and only if there are still possible moves. + -} +isAlive :: Gameplay -> Bool +isAlive = Core.isAlive <$> _gpRule <*> _gpBoard + +{-| + Whether the 'Gameplay' should be considered already won. + Queries 'GameRule' embeded in 'Gameplay'. + -} +hasWon :: Gameplay -> Bool +hasWon = (_grHasWon . _gpRule) <*> _gpScore <*> _gpBoard diff --git a/src/Game/H2048/UI/Brick.hs b/src/Game/H2048/UI/Brick.hs --- a/src/Game/H2048/UI/Brick.hs +++ b/src/Game/H2048/UI/Brick.hs @@ -1,45 +1,41 @@ -{-# LANGUAGE OverloadedStrings, NamedFieldPuns #-} -module Game.H2048.UI.Brick where +{-# LANGUAGE OverloadedStrings #-} +{-| + Game CUI implemented using [brick](https://github.com/jtdaugherty/brick/). + -} + +module Game.H2048.UI.Brick + ( main + ) 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 System.Random.TF -import Game.H2048.Core +import qualified Data.Map.Strict as M -data RName = RBoard deriving (Eq, Ord) +import Game.H2048.Gameplay -type AppState = (Board, Int {- for tracking total score -}) +data RName = RBoard deriving (Eq, Ord) -valToTier :: Int -> Int -valToTier = countTrailingZeros -- tier starting from 1 +type AppState = Gameplay 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, _) = +boardWidget s = joinBorders . border $ grid where - bd = fromBoard bdOpaque + bd = _gpBoard s grid = hLimit (hMax*4+3) $ vBox (intersperse hBorder (row <$> [0..3])) row :: Int -> Widget RName @@ -52,46 +48,46 @@ cell r c = vLimit 1 . hLimit hMax $ cellW where - val = bd !! r !! c - cellW = - if val == 0 - then fill ' ' - else - withAttr (tierAttr . valToTier $ val) + mVal = bd M.!? (r,c) + cellW = case mVal of + Nothing -> fill ' ' + Just ce | tier <- _cTier ce -> + withAttr (tierAttr tier) . padLeft Max - $ str (show (bd !! r !! c) <> " ") + $ str (show (cellToInt ce) <> " ") ui :: AppState -> Widget RName -ui s@(bd,score) = +ui s = center $ hCenter (boardWidget s) <=> hCenter (str $ "Current Score: " <> show score) <=> hCenter (str ctrlHelpMsg) where - GS {hasWon, isAlive} = gameState bd + score = _gpScore s + won = hasWon s + alive = isAlive s 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 + if not alive then - (if hasWon then "You won, but no more moves. " else "No more moves, game over. ") + (if won then "You won, but no more moves. " else "No more moves, game over. ") <> commonHelp else - (if hasWon then "You've won! " else "") + (if won then "You've won! " else "") <> moveHelp <> commonHelp handleEvent :: AppState -> BrickEvent RName e -> EventM RName (Next AppState) -handleEvent s@(bd,score) e = case e of +handleEvent s e = case e of VtyEvent (EvKey (KChar 'q') []) -> halt s VtyEvent (EvKey (KChar 'r') []) -> - liftIO initGameBoard >>= continue + let initState = mkGameplay (_gpGen s) (_gpRule s) + in continue (newGame initState) 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) + | Just dir <- getMove k + , Just gp' <- stepGame dir s -> + continue gp' _ -> continue s getMove :: Key -> Maybe Dir @@ -105,10 +101,12 @@ getMove (KChar 'l') = Just DRight getMove _ = Nothing +-- | The entry for the CUI, a fancier and more practical one. main :: IO () main = do - initGb <- initGameBoard - let app = + g <- newTFGen + let initState = mkGameplay g standardGameRule + app = App { appDraw = \s -> [ui s] , appHandleEvent = handleEvent @@ -131,5 +129,4 @@ ] , appChooseCursor = neverShowCursor } - initState = initGb - void $ defaultMain app initState + void $ defaultMain app (newGame 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 @@ -1,42 +1,31 @@ {-| - 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 - --} -{-# LANGUAGE NamedFieldPuns #-} + A simple program that implements interaction with the game. + -} module Game.H2048.UI.Simple - ( drawBoard - , playGame - , main - , Board - ) -where + ( main + ) 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 Data.Function +import Data.Functor +import Data.List import System.IO +import System.Random.TF +import Text.Printf --- a simple UI implemented by outputing strings +import qualified Data.Map.Strict as M +import Game.H2048.Gameplay + +-- a simple command line interface implemented by simply 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 bd = +drawBoard :: Gameplay -> IO () +drawBoard gp = {- a cell will be represented in the output as following: @@ -52,97 +41,85 @@ * finalize this line by printing out the horizontal "+--+--+..." -} putStrLn horizSeparator >> - mapM_ drawRow (fromBoard bd) + mapM_ drawRow [0 .. rowCount - 1] where + bd = _gpBoard gp + (rowCount, colCount) = _grDim . _gpRule $ gp 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 row = do + prettyCell :: Int -> Int -> String + prettyCell r c = case bd M.!? (r,c) of + Nothing -> replicate cellWidth ' ' + Just cell -> printf " %4d " (cellToInt cell) + + drawRow :: Int -> IO () + drawRow rowInd = do -- prints "| | | ... |" putChar '|' - mapM_ (prettyCell >>> putStr >>> (>> putChar '|')) row + mapM_ (prettyCell rowInd >>> putStr >>> (>> putChar '|')) [0 .. colCount - 1] putChar '\n' putStrLn horizSeparator -- | play game on a given board until user quits or game ends -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) +playGame :: IO Gameplay +playGame = do + g <- newTFGen + let initState = mkGameplay g standardGameRule + gameLoop (newGame initState) 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 + gameLoop gp = do + drawBoard gp + if isAlive gp + then processUserMove gp + else endGame gp + + endGame gp = do + putStrLn $ if hasWon gp then "You won" else "Game over" + _ <- printf "Final score: %d\n" (_gpScore gp) + gp <$ 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 + processUserMove :: Gameplay -> IO Gameplay + processUserMove gp = fix $ \redo -> do let scoreFormat = - if w + if hasWon gp then "You win, current score: %d\n" else "Current score: %d\n" - drawBoard b - _ <- printf scoreFormat score + printf scoreFormat (_gpScore gp) 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 + 'q' -> pure gp + 'i' -> putStrLn "Up" >> handleMove gp DUp + 'k' -> putStrLn "Down" >> handleMove gp DDown + 'j' -> putStrLn "Left" >> handleMove gp DLeft + 'l' -> putStrLn "Right" >> handleMove gp DRight + _ -> -- 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))) + putStrLn helpString >> redo --- | the entry of Simple UI + handleMove :: Gameplay -> Dir -> IO Gameplay + handleMove gp dir = case stepGame dir gp of + Nothing -> putStrLn "Invalid move" >> gameLoop gp + Just gp' -> gameLoop gp' + +-- | The entry of simple CLI. main :: IO () main = do - bfMod <- hGetBuffering stdin - -- no buffering - don't wait for the "enter" - hSetBuffering stdin NoBuffering - g <- newStdGen - -- 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 - -- restoring buffering setting - hSetBuffering stdin bfMod + -- turn off buffering to not wait on a newline character. + hSetBuffering stdin NoBuffering + -- show some helpful messages + -- whether the user has read the README or not :) + putStrLn helpString + -- initialize game based on the random seed + void playGame diff --git a/src/Game/H2048/Utils.hs b/src/Game/H2048/Utils.hs deleted file mode 100644 --- a/src/Game/H2048/Utils.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-| - 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 - ) -where - -import Control.Lens - --- | 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 = over (ix n) diff --git a/test/Game/H2048/CoreSpec.hs b/test/Game/H2048/CoreSpec.hs --- a/test/Game/H2048/CoreSpec.hs +++ b/test/Game/H2048/CoreSpec.hs @@ -1,78 +1,227 @@ -module Game.H2048.CoreSpec where +{-# LANGUAGE TupleSections #-} +module Game.H2048.CoreSpec + ( spec + , listToGameBoard + , gameBoardToList + ) where +import Control.Monad +import Data.Bifunctor import Test.Hspec +import qualified Data.IntMap as IM +import qualified Data.Map as M +import qualified Data.Vector as V +import qualified Data.Set as S + import Game.H2048.Core +listToGameBoard :: (Int, Int) -> [[Int]] -> GameBoard +listToGameBoard (rows,cols) grid = + M.fromList $ zip coords (convert <$> concat grid) >>= unwrap + where + coords = (,) <$> [0..rows-1] <*> [0..cols-1] + convert v = + if v == 0 + then Nothing + else Just (unsafeIntToCell v) + unwrap (coord, m) = case m of + Nothing -> [] + Just m' -> [(coord, m')] + +gameBoardToList :: (Int, Int) -> GameBoard -> [[Int]] +gameBoardToList (rows,cols) gb = + (\r -> convert r <$> [0..cols-1]) <$> [0..rows-1] + where + convert rInd cInd = case M.lookup (rInd,cInd) gb of + Nothing -> 0 + Just c -> cellToInt c + spec :: Spec spec = do - describe "compactLine" $ + let gr = standardGameRule + + describe "merge" $ do + specify "no merge" $ do + merge (Cell 1) (Cell 2) `shouldBe` Nothing + merge (Cell 6) (Cell 5) `shouldBe` Nothing + specify "merges" $ do + merge (Cell 1) (Cell 1) `shouldBe` Just (Cell 2) + merge (Cell 4) (Cell 4) `shouldBe` Just (Cell 5) + + describe "mergeWithScore" $ 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]) + mergeWithScore gr (Cell 1) (Cell 1) + `shouldBe` Just (Cell 2, 4) + mergeWithScore gr (Cell 4) (Cell 4) + `shouldBe` Just (Cell 5, 32) - 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 + describe "mergeLines" $ + specify "examples" $ do + let mergeLine' = + first (fmap cellToInt) + . mergeLine gr + . fmap unsafeIntToCell + mergeLine' [] `shouldBe` ([], 0) + mergeLine' [1,1] `shouldBe` ([2], 2) + mergeLine' [2,2,4] `shouldBe` ([4,4], 4) + mergeLine' [4,4,4] `shouldBe` ([8,4], 8) + mergeLine' [4,8,8] `shouldBe` ([4,16], 16) + mergeLine' [4,2,2,8] `shouldBe` ([4,4,8], 4) + mergeLine' [2,4,4,2] `shouldBe` ([2,8,2], 8) + mergeLine' [2,2,2,2] `shouldBe` ([4,4], 8) + mergeLine' [1,2] `shouldBe` ([1,2], 0) + + describe "computeDistrib" $ + specify "examples" $ + computeDistrib (IM.fromList [(1,2),(2,5),(3,7),(4,6)]) + `shouldBe` V.fromList [(1,2),(2,7),(3,14),(4,20)] + + describe "allCoords" $ do + specify "standard" $ + (S.toAscList . S.fromList . allCoords $ gr) `shouldBe` + allCoords gr + specify "non-square" $ + let gr' = gr { _grDim = (4,5) } + in (S.toAscList . S.fromList . allCoords $ gr') `shouldBe` + allCoords gr' + + describe "dirToCoordsGroups" $ do + specify "standard game examples" $ do + let testCase dir expected = + dirToCoordsGroups gr dir + `shouldBe` expected + testCase DUp $ + fmap (\c -> fmap (,c) [0..3]) [0..3] + testCase DDown $ + fmap (\c -> fmap (,c) [3,2..0]) [0..3] + testCase DLeft $ + fmap (\r -> fmap (r,) [0..3]) [0..3] + testCase DRight $ + fmap (\r -> fmap (r,) [3,2..0]) [0..3] + specify "non-square examples" $ do + let testCase dir expected = + dirToCoordsGroups (gr {_grDim = (3,5)}) dir + `shouldBe` expected + testCase DUp $ + fmap (\c -> fmap (,c) [0..2]) [0..4] + testCase DDown $ + fmap (\c -> fmap (,c) [2,1,0]) [0..4] + testCase DLeft $ + fmap (\r -> fmap (r,) [0..4]) [0..2] + testCase DRight $ + fmap (\r -> fmap (r,) [4,3..0]) [0..2] + + describe "applyMove" $ + describe "examples" $ do + let toGB = listToGameBoard (_grDim gr) + -- used for testing while describing board as a list + testCase listBd dir expected = + (fmap . first) (gameBoardToList (_grDim gr)) + (applyMove gr dir (toGB listBd)) + `shouldBe` expected + -- for making it convenient to test for multiple + -- directions on the same board configuration. + testCases descPref listBd expects = + forM_ expects $ \(dir, expectedListBd) -> + specify (descPref <> ", " <> show dir) $ + testCase listBd dir expectedListBd + + testCases "case #0" + [ [2,2,2,2] + , [2,4,4,2] + , [2,4,4,2] + , [2,2,2,2] + ] + [ ( DUp + , Just ([ [4,2,2,4] + , [4,8,8,4] + , [0,2,2,0] + , [0,0,0,0] + ], 32)) + , ( DDown + , Just ([ [0,0,0,0] + , [0,2,2,0] + , [4,8,8,4] + , [4,2,2,4] + ], 32)) + , ( DLeft + , Just ([ [4,4,0,0] + , [2,8,2,0] + , [2,8,2,0] + , [4,4,0,0] + ], 32)) + , ( DRight + , Just ([ [0,0,4,4] + , [0,2,8,2] + , [0,2,8,2] + , [0,0,4,4] + ], 32)) + ] + testCases "case #1" + [ [2,2,4,4] + , [2,2,4,4] + , [8,8,0,0] + , [8,8,0,0] + ] + [ ( DUp + , Just ([ [ 4, 4 ,8, 8] + , [16,16, 0, 0] + , [ 0, 0, 0, 0] + , [ 0, 0, 0, 0] + ], 56)) + , ( DDown + , Just ([ [ 0, 0, 0, 0] + , [ 0, 0, 0, 0] + , [ 4, 4, 0, 0] + , [16,16, 8, 8] + ], 56)) + , ( DLeft + , Just ([ [ 4, 8, 0, 0] + , [ 4, 8, 0, 0] + , [16, 0, 0, 0] + , [16, 0, 0, 0] + ], 56)) + , ( DRight + , Just ([ [ 0, 0, 4, 8] + , [ 0, 0, 4 ,8] + , [ 0, 0, 0,16] + , [ 0, 0, 0,16] + ], 56)) + ] + testCases "case #2" + [ [0,0,0,0] + , [2,0,0,0] + , [4,4,0,0] + , [8,2,8,0] + ] + [ ( DUp + , Just ([ [2,4,8,0] + , [4,2,0,0] + , [8,0,0,0] + , [0,0,0,0] + ], 0)) + , ( DDown + , Nothing) + , ( DLeft + , Just ([ [0,0,0,0] + , [2,0,0,0] + , [8,0,0,0] + , [8,2,8,0] + ], 8)) + , ( DRight + , Just ([ [0,0,0,0] + , [0,0,0,2] + , [0,0,0,8] + , [0,8,2,8] + ], 8)) + ] + testCases "no more moves" + [ [2,4,2,4] + , [4,2,4,2] + , [8,4,8,4] + , [2,8,4,2] + ] $ fmap (,Nothing) [DUp, DDown, DLeft, DRight] + testCases "uninitialized" + (replicate 4 (replicate 4 0)) $ + fmap (,Nothing) [DUp, DDown, DLeft, DRight] diff --git a/test/Game/H2048/GameplaySpec.hs b/test/Game/H2048/GameplaySpec.hs new file mode 100644 --- /dev/null +++ b/test/Game/H2048/GameplaySpec.hs @@ -0,0 +1,78 @@ +module Game.H2048.GameplaySpec + ( spec + ) where + +import Test.Hspec +import System.Random.TF + +import Game.H2048.CoreSpec (listToGameBoard) +import Game.H2048.Gameplay + +spec :: Spec +spec = + describe "isAlive & hasWon" $ do + let -- following pairs stand for (, ) + gWonAlive = (True, True) + gWonOver = (True, False) + gAlive = (False, True) + gLose = (False, False) + testCase boardList expected = do + let gp = + (mkGameplay + (mkTFGen 0xDEADBEEF) + standardGameRule) + { _gpBoard = + listToGameBoard + (_grDim . _gpRule $ gp) + boardList + } + (hasWon gp, isAlive gp) `shouldBe` expected + specify "trivial win, alive" $ + testCase + [ [ 2048, 2048, 2048, 2048 ] + , [ 0, 0, 0, 0 ] + , [ 0, 0, 0, 0 ] + , [ 0, 0, 0, 0 ] + ] gWonAlive + specify "more than 2048 (might not happen in practice)" $ + testCase + [ [ 256, 2, 4, 8 ] + , [ 16, 32, 64, 128 ] + , [ 256, 512, 1024, 8 ] + , [ 16, 4096, 128, 64 ] + ] gWonOver + specify "no more move but win" $ + testCase + [ [ 2, 4, 2, 4 ] + , [ 4, 2048, 4, 2 ] + , [ 2, 4, 2, 4 ] + , [ 4, 2, 4, 2 ] + ] gWonOver + specify "trivial alive" $ + testCase + [ [ 2, 0, 0, 8 ] + , [ 4, 0, 0, 8 ] + , [ 4, 0, 0, 8 ] + , [ 1024, 512, 128, 64 ] + ] gAlive + specify "no empty cell but still alive" $ + testCase + [ [ 512, 128, 512, 128 ] + , [ 128, 512, 128, 512 ] + , [ 512, 128, 512, 128 ] + , [ 128, 512, 128, 128 ] + ] gAlive + specify "trivial lose 1" $ + testCase + [ [ 2, 4, 2, 4 ] + , [ 4, 2, 4, 2 ] + , [ 2, 4, 2, 4 ] + , [ 4, 2, 4, 2 ] + ] gLose + specify "trivial lose 2" $ + testCase + [ [ 2, 8, 32, 2 ] + , [ 4, 2, 8, 4 ] + , [ 32, 16, 128, 16 ] + , [ 4, 8, 4, 2 ] + ] gLose