h2048 0.3.0.0 → 0.4.0.0

raw patch · 10 files changed

+1034/−496 lines, 10 filesdep +containersdep +tf-randomdep +vectordep −MonadRandomdep −lensPVP ok

version bump matches the API change (PVP)

Dependencies added: containers, tf-random, vector, vector-algorithms

Dependencies removed: MonadRandom, lens

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−7
• README.md +27/−49
• h2048.cabal +19/−10
• src/Game/H2048/Core.hs +383/−203
• src/Game/H2048/Gameplay.hs +194/−0
• src/Game/H2048/UI/Brick.hs +40/−43
• src/Game/H2048/UI/Simple.hs +67/−90
• src/Game/H2048/Utils.hs +0/−25
• test/Game/H2048/CoreSpec.hs +218/−69
• test/Game/H2048/GameplaySpec.hs +78/−0

@@ -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`

@@ -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.

@@ -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

@@ -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-  (<move>, <board-after-that-move), so making the next move is-  as simple as picking a move and replace state with `snd` part of that move.-  and if the list is empty, we know there are no more moves and we are done.--}+  * Moving on one direction squeezes out those empty cells,+    therefore it is not necessary to consider empty cells at all.+  * Similar rationale for output type - the result is always+    a line of cells free of empty ones in between any of those.+ -}+mergeLine :: GameRule -> [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

@@ -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

@@ -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)

@@ -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 "| <cell1> | <cell2> | ... |"       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 <key>   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

@@ -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)

@@ -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]

@@ -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 (<won?>, <alive?>)+        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