diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,80 @@ +# h2048 + +[![Build Status](https://travis-ci.org/Javran/h2048.svg?branch=master)](https://travis-ci.org/Javran/h2048) + +a haskell implementation of Game 2048 + +Based on [2048](https://github.com/gabrielecirulli/2048) + +# Screenshots + +## Simple CLI version + +![](https://github.com/Javran/h2048/releases/download/0.1.0.0/h2048-simple.jpg) + +## vty CLI version + +![](https://github.com/Javran/h2048/releases/download/0.1.0.0/h2048-vty.jpg) + +## 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/h2048.cabal b/h2048.cabal new file mode 100644 --- /dev/null +++ b/h2048.cabal @@ -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 . + +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 diff --git a/src/MainSimple.hs b/src/MainSimple.hs new file mode 100644 --- /dev/null +++ b/src/MainSimple.hs @@ -0,0 +1,7 @@ +module Main +where + +import System.Game.H2048.UI.Simple + +main :: IO () +main = mainSimple diff --git a/src/MainVty.hs b/src/MainVty.hs new file mode 100644 --- /dev/null +++ b/src/MainVty.hs @@ -0,0 +1,7 @@ +module Main +where + +import System.Game.H2048.UI.Vty + +main :: IO () +main = mainVty diff --git a/src/System/Game/H2048/Core.hs b/src/System/Game/H2048/Core.hs new file mode 100644 --- /dev/null +++ b/src/System/Game/H2048/Core.hs @@ -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 diff --git a/src/System/Game/H2048/Utils.hs b/src/System/Game/H2048/Utils.hs new file mode 100644 --- /dev/null +++ b/src/System/Game/H2048/Utils.hs @@ -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 diff --git a/src/Test.hs b/src/Test.hs new file mode 100644 --- /dev/null +++ b/src/Test.hs @@ -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 + ]