h2048 (empty) → 0.1.0.1
raw patch · 9 files changed
+534/−0 lines, 9 filesdep +HUnitdep +MonadRandomdep +basesetup-changed
Dependencies added: HUnit, MonadRandom, base, mtl, text, transformers, vty, vty-ui
Files
- LICENSE +21/−0
- README.md +80/−0
- Setup.hs +2/−0
- h2048.cabal +84/−0
- src/MainSimple.hs +7/−0
- src/MainVty.hs +7/−0
- src/System/Game/H2048/Core.hs +207/−0
- src/System/Game/H2048/Utils.hs +38/−0
- src/Test.hs +88/−0
+ LICENSE view
@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) 2014 Javran Cheng++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ README.md view
@@ -0,0 +1,80 @@+# h2048++[](https://travis-ci.org/Javran/h2048)++a haskell implementation of Game 2048++Based on [2048](https://github.com/gabrielecirulli/2048)++# Screenshots++## Simple CLI version++++## vty CLI version++++## Build and run++### With cabal++If you have [Cabal](http://www.haskell.org/cabal/) installed,+you can use the following command to build this project:++ cabal build++The executable will be located at `dist/build/h2048-simple/h2048-vty`,+to run the program:++ ./dist/build/h2048-simple/h2048-vty++Or alternatively:++ cabal run h2048-vty++If you have trouble building the `vty` CLI version,+you can try to turn off feature `vty` and use `h2028-simple`:++ cabal configure --flag="-vty"+ cabal build+ # now the program should be ready+ cabal run h2048-simple+ # or alternatively:+ ./dist/build/h2048-simple/h2048-simple++### 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:++ 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++## How to play++keys:++* `q`: quit+* `i`: up+* `k`: down+* `j`: left+* `l`: right++If you are using `h2048-vty`, you can also use arrow keys.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ h2048.cabal view
@@ -0,0 +1,84 @@+-- Initial h2048.cabal generated by cabal init. For further documentation,+-- see http://haskell.org/cabal/users-guide/++name: h2048+version: 0.1.0.1+synopsis: a haskell implementation of Game 2048+description: a haskell implementation of Game 2048,+ based on <https://github.com/gabrielecirulli/2048>.++homepage: https://github.com/Javran/h2048+license: MIT+license-file: LICENSE+author: Javran Cheng+maintainer: Javran.C@gmail.com+copyright: Copyright (c) 2014 Javran Cheng+category: Game+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++flag exe+ description: build executables+ default: True++flag vty+ description: build UI written in vty-ui+ default: True++library+ hs-source-dirs: src+ exposed-modules: System.Game.H2048.Core,+ System.Game.H2048.Utils++ build-depends: base >= 4 && < 5,+ transformers >= 0 && < 1,+ mtl >= 2 && < 3,+ MonadRandom >= 0 && < 1++ ghc-options: -Wall+ default-language: Haskell2010++executable h2048-simple+ hs-source-dirs: src+ main-is: MainSimple.hs+ ghc-options: -Wall+ build-depends: base >= 4 && < 5,+ transformers >= 0 && < 1,+ mtl >= 2 && < 3,+ MonadRandom >= 0 && < 1++ if ! flag(exe)+ buildable: False++ default-language: Haskell2010++executable h2048-vty+ hs-source-dirs: src+ main-is: MainVty.hs+ ghc-options: -Wall+ build-depends: base >= 4 && < 5,+ text >= 1 && < 2,+ vty >= 4 && < 5,+ vty-ui >= 1 && < 2,+ transformers >= 0 && < 1,+ mtl >= 2 && < 3,+ MonadRandom >= 0 && < 1++ if ! flag(exe) || ! flag(vty)+ buildable: False++ default-language: Haskell2010++Test-Suite test+ hs-source-dirs: src+ type: exitcode-stdio-1.0+ main-is: Test.hs+ ghc-options: -Wall+ build-depends: base >= 4 && < 5,+ MonadRandom >= 0 && < 1,+ transformers >= 0 && < 1,+ mtl >= 2 && < 3,+ HUnit >= 1 && < 2++ default-language: Haskell2010
+ src/MainSimple.hs view
@@ -0,0 +1,7 @@+module Main+where++import System.Game.H2048.UI.Simple++main :: IO ()+main = mainSimple
+ src/MainVty.hs view
@@ -0,0 +1,7 @@+module Main+where++import System.Game.H2048.UI.Vty++main :: IO ()+main = mainVty
+ src/System/Game/H2048/Core.hs view
@@ -0,0 +1,207 @@+{-|+ Module : System.Game.H2048.Core+ Copyright : (c) 2014 Javran Cheng+ License : MIT+ Maintainer : Javran.C@gmail.com+ Stability : experimental+ Portability : POSIX++The core game logic implementation for Game 2048.++The routine for using this library would be:++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.++3. use `insertNewCell` to insert a new cell randomly++4. examine if the player wins / loses / is still alive using `gameState`.++-}+module System.Game.H2048.Core+ ( Board+ , Line+ , Dir (..)+ , BoardUpdated (..)+ , GameState (..)+ , gameState+ , compactLine+ , initBoard+ , initGameBoard+ , updateBoard+ , insertNewCell+ , generateNewCell+ )+where++import Control.Arrow+import Control.Monad+import Control.Monad.Writer+import Control.Monad.Random+import Data.List+import Data.Maybe++import System.Game.H2048.Utils++-- | represent a 4x4 board for Game 2048+-- each element should be either zero or 2^i+-- where i >= 1.+type Board = [[Int]]++-- | a list of 4 elements, stands for+-- one column / row in the board+type Line = [Int]++-- | result after a successful 'updateBoard'+data BoardUpdated = BoardUpdated+ { brBoard :: Board -- ^ new board+ , brScore :: Int -- ^ score collected in this update+ } deriving (Eq, Show)++-- | current game state, see also 'gameState'+data GameState = Win+ | Lose+ | Alive+ deriving (Enum, Eq, Show)++-- | move direction+data Dir = DUp+ | DDown+ | DLeft+ | DRight+ deriving (Enum, Bounded, Eq, Ord, Show)++-- | the initial board before a game started+initBoard :: Board+initBoard = (replicate 4 . replicate 4) 0++-- | move each non-zero element to their leftmost possible+-- position while preserving the order+compactLine :: Line -> Writer (Sum Int) Line+compactLine = runKleisli+ -- remove zeros+ ( filter (/=0)+ -- do merge and collect score+ ^>> Kleisli merge+ -- restore zeros, on the "fst" part+ >>^ take 4 . (++ repeat 0))++ where+ merge :: [Int] -> Writer (Sum Int) [Int]+ merge (x:y:xs) =+ if x == y+ -- only place where score are collected.+ then do+ -- try to merge first two elements,+ -- and process rest of it.+ xs' <- merge xs+ tell . Sum $ x + y+ return $ (x+y) : xs'+ else do+ -- just skip the first one,+ -- and process rest of it.+ xs' <- merge (y:xs)+ return $ x : xs'+ merge r = return r++-- | update the board taking a direction,+-- a 'BoardUpdated' is returned on success,+-- if this update does nothing, that means a failure (Nothing)+updateBoard :: Dir -> Board -> Maybe BoardUpdated+updateBoard d board = if board /= board'+ then Just $ BoardUpdated board' (getSum score)+ else Nothing+ where+ board' :: Board+ -- transform boards so that+ -- we only focus on "gravitize to the left".+ -- and convert back after the gravitization is done.+ (board',score) = runWriter $+ runKleisli+ -- transform to a "gravitize to the left" problem+ ( rTransL+ -- gravitize to the left+ ^>> Kleisli (mapM compactLine)+ -- transform back+ >>^ rTransR) board++ -- rTrans for "a list of reversible transformations, that will be performed in order"+ rTrans :: [Board -> Board]+ rTrans =+ case d of+ -- the problem itself is "gravitize to the left"+ DLeft -> []+ -- we use a mirror+ DRight -> [map reverse]+ -- diagonal mirror+ DUp -> [transpose]+ -- same as DUp case + DRight case+ DDown -> [transpose, map reverse]++ -- how we convert it "into" and "back"+ rTransL = foldl (flip (.)) id rTrans+ rTransR = foldr (.) id rTrans++-- | find blank cells in a board,+-- return coordinates for each blank cell+blankCells :: Board -> [(Int, Int)]+blankCells b = map (\(row, (col, _)) -> (row,col)) blankCells'+ where+ blankCells' = filter ((== 0) . snd . snd) linearBoard+ -- flatten to make it ready for filter+ linearBoard = concat $ zipWith tagRow [0..] colTagged++ -- tag cells with row num+ tagRow row = map ( (,) row )+ -- tag cells with column num+ colTagged = map (zip [0..]) b++-- | return current game state.+-- 'Win' if any cell is equal to or greater than 2048+-- or 'Lose' if we can move no further+-- otherwise, 'Alive'.+gameState :: Board -> GameState+gameState b+ | any (>= 2048) . concat $ b+ = Win+ | all (isNothing . ( `updateBoard` b)) universe+ = Lose+ | otherwise+ = Alive++-- | initialize the board by puting two cells randomly+-- into the board.+-- See 'generateNewCell' for the cell generating rule.+initGameBoard :: (MonadRandom r) => r (Board, Int)+initGameBoard =+ -- insert two cells and return the resulting board+ -- here we can safely assume that the board has at least two empty cells+ -- so that we can never have Nothing on the LHS+ liftM ( (\x -> (x,0)) . fromJust) (insertNewCell initBoard >>= (insertNewCell . fromJust))++-- | try to insert a new cell randomly+insertNewCell :: (MonadRandom r) => Board -> r (Maybe Board)+insertNewCell b = do+ -- get a list of coordinates of blank cells+ let availableCells = blankCells b++ if null availableCells+ -- cannot find any empty cell, then fail+ then return Nothing+ else do+ -- randomly pick up an available cell by choosing index+ choice <- getRandomR (0, length availableCells - 1)+ let (row,col) = availableCells !! choice+ value <- generateNewCell+ return $ Just $ (inPos row . inPos col) (const value) b++-- | generate a new cell according to the game rule+-- we have 90% probability of getting a cell of value 2,+-- and 10% probability of getting a cell of value 4.+generateNewCell :: (MonadRandom r) => r Int+generateNewCell = do+ r <- getRandom+ return $ if r < (0.9 :: Float) then 2 else 4
+ src/System/Game/H2048/Utils.hs view
@@ -0,0 +1,38 @@+{-|+ Module : System.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 System.Game.H2048.Utils+ ( inPos+ , universe+ )+where++-- provide utilities++-- | all possible values for a Bounded Enum+universe :: (Bounded e, Enum e) => [e]+universe = [minBound .. maxBound]++-- | 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 f xs+ | null xs = xs+ | n < 0 = xs+ -- for all the cases below,+ -- safely assume n >= 0 and xs is not empty+ | n == 0 = let (y:ys) = xs+ in f y : ys+ | otherwise = let (y:ys) = xs+ in y : inPos (n - 1) f ys
+ src/Test.hs view
@@ -0,0 +1,88 @@+import Test.HUnit++import Control.Arrow+import Control.Monad+import Control.Monad.Writer+import System.Exit++import System.Game.H2048.Core++-- | the expected behavior of 'compactLine'+compactLineTestcases :: [ ((Line, Int) , Line) ]+compactLineTestcases =+ -- < expected > < input >+ [ ( ([0,0,0,0],0), [0,0,0,0] )+ , ( ([2,0,0,0],2), [1,0,0,1] )+ , ( ([4,4,0,0],8), [2,2,2,2] )+ , ( ([2,8,2,0],8), [2,4,4,2] )+ , ( ([2,4,8,2],0), [2,4,8,2] )+ , ( ([2,0,0,0],2), [0,1,0,1] )+ , ( ([1,2,0,0],0), [1,0,2,0] )+ ]++compactLineTests :: Test+compactLineTests = TestLabel "compactLine" . TestList . map+ (\(expected, inp) ->+ expected ~=?+ second getSum (runWriter (compactLine inp)))+ $ compactLineTestcases++-- | the expected behavior of 'gameState'+gameStateTestcases :: [ (String, GameState, Board) ]+gameStateTestcases =+ [ ( "trivial win",+ Win , [ [ 2048, 2048, 2048, 2048 ]+ , [ 0, 0, 0, 0 ]+ , [ 0, 0, 0, 0 ]+ , [ 0, 0, 0, 0 ] ] )+ , ( "more than 2048 (might not happen in practice)",+ Win , [ [ 256, 2, 4, 8 ]+ , [ 16, 32, 64, 128 ]+ , [ 256, 512, 1024, 8 ]+ , [ 16, 4096, 128, 64 ] ] )+ , ( "no more move but win",+ Win , [ [ 2, 4, 2, 4 ]+ , [ 4, 2048, 4, 2 ]+ , [ 2, 4, 2, 4 ]+ , [ 4, 2, 4, 2 ] ] )+ , ( "trivial alive",+ Alive , [ [ 2, 0, 0, 8 ]+ , [ 4, 0, 0, 8 ]+ , [ 4, 0, 0, 8 ]+ , [ 1024, 512, 128, 64 ] ] )+ , ( "no empty cell but still alive",+ Alive , [ [ 512, 128, 512, 128 ]+ , [ 128, 512, 128, 512 ]+ , [ 512, 128, 512, 128 ]+ , [ 128, 512, 128, 128 ] ] )+ , ( "trivial lose 1",+ Lose , [ [ 2, 4, 2, 4 ]+ , [ 4, 2, 4, 2 ]+ , [ 2, 4, 2, 4 ]+ , [ 4, 2, 4, 2 ] ] )+ , ( "trivial lose 2",+ Lose , [ [ 2, 8, 32, 2 ]+ , [ 4, 2, 8, 4 ]+ , [ 32, 16, 128, 16 ]+ , [ 4, 8, 4, 2 ] ] )+ ]++gameStateTests :: Test+gameStateTests = TestLabel "gameState" . TestList . map+ (\(lbl, expected, inp) ->+ TestLabel lbl (expected ~=? gameState inp))+ $ gameStateTestcases++-- | run testcase and quit immediately after a failure+runTestFailIm :: Test -> IO ()+runTestFailIm t = do+ cs <- runTestTT t+ print cs+ when (errors cs > 0 || failures cs > 0)+ exitFailure++main :: IO ()+main = mapM_ runTestFailIm+ [ compactLineTests+ , gameStateTests+ ]