h2048 0.2.0.1 → 0.3.0.0

raw patch · 16 files changed

+590/−659 lines, 16 filesdep +brickdep +h2048dep +hspecdep −HUnitdep −transformersdep −vty-uidep ~MonadRandomdep ~basedep ~mtlsetup-changednew-component:exe:h2048-brickPVP ok

version bump matches the API change (PVP)

Dependencies added: brick, h2048, hspec, lens

Dependencies removed: HUnit, transformers, vty-ui

Dependency ranges changed: MonadRandom, base, mtl, text, vty

API changes (from Hackage documentation)

Files

• CHANGELOG.md +9/−5
• LICENSE +1/−1
• Setup.hs +0/−2
• exe/BrickUi.hs +3/−0
• exe/Simple.hs +3/−0
• h2048.cabal +89/−86
• src/Game/H2048/Core.hs +176/−135
• src/Game/H2048/UI/Brick.hs +135/−0
• src/Game/H2048/UI/Simple.hs +91/−104
• src/Game/H2048/UI/Vty.hs +0/−207
• src/Game/H2048/Utils.hs +4/−17
• src/MainSimple.hs +0/−7
• src/MainVty.hs +0/−7
• src/Test.hs +0/−88
• test/Game/H2048/CoreSpec.hs +78/−0
• test/Spec.hs +1/−0

@@ -1,10 +1,14 @@+# 1.0.0.0 (pending)++- scrap direct `vty` support due to its deprecation.+ # 0.2.0.1 -* build with vty 5 and vty-ui 1.8 (thanks to @vikraman)+- build with vty 5 and vty-ui 1.8 (thanks to @vikraman)  # 0.2.0.0 -* conditional flags: `exe` and `vty`-* can now proceed after winning the game-* version number changed from `0.1.0.3` to `0.2.0.0` due to version policy-* change `System.Game` to `Game`+- conditional flags: `exe` and `vty`+- can now proceed after winning the game+- version number changed from `0.1.0.3` to `0.2.0.0` due to version policy+- change `System.Game` to `Game`

@@ -1,6 +1,6 @@ The MIT License (MIT) -Copyright (c) 2014 Javran Cheng+Copyright (c) 2014-2019 Javran Cheng  Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal

@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain

@@ -0,0 +1,3 @@+module BrickUi (main) where++import Game.H2048.UI.Brick

@@ -0,0 +1,3 @@+module Simple (main) where++import Game.H2048.UI.Simple

@@ -1,95 +1,98 @@--- Initial h2048.cabal generated by cabal init.  For further documentation,---  see http://haskell.org/cabal/users-guide/--name:                h2048-version:             0.2.0.1-synopsis:            a haskell implementation of Game 2048+cabal-version: 1.12+name: h2048+version: 0.3.0.0+license: MIT+license-file: LICENSE+maintainer: Javran.C@gmail.com+author: Javran Cheng+homepage: https://github.com/Javran/h2048#readme+bug-reports: https://github.com/Javran/h2048/issues+synopsis: An Implementation of Game 2048 description:--  A haskell implementation of Game 2048,-  based on <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, CHANGELOG.md-cabal-version:       >=1.10--flag exe-  description:         build executables-  default:             True+    An Implementation of Game 2048, based on <https://github.com/gabrielecirulli/2048>.+category: Game+build-type: Simple+extra-source-files:+    README.md+    CHANGELOG.md -flag vty-  description:         build UI written in vty-ui-  default:             True+source-repository head+    type: git+    location: https://github.com/Javran/h2048  library-  hs-source-dirs:      src-  exposed-modules:     Game.H2048.Core,-                       Game.H2048.Utils-  if flag(exe)-    exposed-modules:   Game.H2048.UI.Simple--  if flag(exe) && flag(vty)     exposed-modules:-                       Game.H2048.UI.Vty--  build-depends:       base >= 4 && < 5,-                       transformers >= 0 && < 1,-                       mtl >= 2 && < 3,-                       MonadRandom >= 0 && < 1,-                       text >= 1 && < 2,-                       vty >= 5 && < 6,-                       vty-ui >= 1.8 && < 2+        Game.H2048.Core+        Game.H2048.UI.Brick+        Game.H2048.UI.Simple+        Game.H2048.Utils+    hs-source-dirs: src+    other-modules:+        Paths_h2048+    default-language: Haskell2010+    build-depends:+        MonadRandom >=0.5.1.1 && <0.6,+        base >=4.12.0.0 && <4.13,+        brick >=0.47.1 && <0.48,+        lens >=4.17.1 && <4.18,+        mtl >=2.2.2 && <2.3,+        text >=1.2.3.1 && <1.3,+        vty >=5.25.1 && <5.26 -  ghc-options:         -Wall-  default-language:    Haskell2010+executable h2048-brick+    main-is: BrickUi.hs+    hs-source-dirs: exe+    other-modules:+        Simple+        Paths_h2048+    default-language: Haskell2010+    ghc-options: -threaded -O2 -rtsopts -with-rtsopts=-N -main-is+                 BrickUi+    build-depends:+        MonadRandom >=0.5.1.1 && <0.6,+        base >=4.12.0.0 && <4.13,+        brick >=0.47.1 && <0.48,+        h2048 -any,+        lens >=4.17.1 && <4.18,+        mtl >=2.2.2 && <2.3,+        text >=1.2.3.1 && <1.3,+        vty >=5.25.1 && <5.26  executable h2048-simple-  hs-source-dirs:      src-  main-is:             MainSimple.hs-  ghc-options:         -Wall-  build-depends:       base >= 4 && < 5,-                       transformers >= 0 && < 1,-                       mtl >= 2 && < 3,-                       MonadRandom >= 0 && < 1--  if ! flag(exe)-    buildable:         False--  default-language:    Haskell2010--executable h2048-vty-  hs-source-dirs:      src-  main-is:             MainVty.hs-  ghc-options:         -Wall -threaded-  build-depends:       base >= 4 && < 5,-                       text >= 1 && < 2,-                       vty >= 5 && < 6,-                       vty-ui >= 1.8 && < 2,-                       transformers >= 0 && < 1,-                       mtl >= 2 && < 3,-                       MonadRandom >= 0 && < 1--  if ! flag(exe) || ! flag(vty)-    buildable:         False--  default-language:    Haskell2010--Test-Suite test-  hs-source-dirs:      src-  type:                exitcode-stdio-1.0-  main-is:             Test.hs-  ghc-options:         -Wall-  build-depends:       base >= 4 && < 5,-                       MonadRandom >= 0 && < 1,-                       transformers >= 0 && < 1,-                       mtl >= 2 && < 3,-                       HUnit >= 1 && < 2+    main-is: Simple.hs+    hs-source-dirs: exe+    other-modules:+        BrickUi+        Paths_h2048+    default-language: Haskell2010+    ghc-options: -threaded -O2 -rtsopts -with-rtsopts=-N -main-is+                 Simple+    build-depends:+        MonadRandom >=0.5.1.1 && <0.6,+        base >=4.12.0.0 && <4.13,+        brick >=0.47.1 && <0.48,+        h2048 -any,+        lens >=4.17.1 && <4.18,+        mtl >=2.2.2 && <2.3,+        text >=1.2.3.1 && <1.3,+        vty >=5.25.1 && <5.26 -  default-language:    Haskell2010+test-suite hspec+    type: exitcode-stdio-1.0+    main-is: Spec.hs+    hs-source-dirs: test+    other-modules:+        Game.H2048.CoreSpec+        Paths_h2048+    default-language: Haskell2010+    ghc-options: -threaded -O2 -rtsopts -with-rtsopts=-N -main-is Spec+    build-depends:+        MonadRandom >=0.5.1.1 && <0.6,+        base >=4.12.0.0 && <4.13,+        brick >=0.47.1 && <0.48,+        h2048 -any,+        hspec >=2.7.1 && <2.8,+        lens >=4.17.1 && <4.18,+        mtl >=2.2.2 && <2.3,+        text >=1.2.3.1 && <1.3,+        vty >=5.25.1 && <5.26

@@ -21,193 +21,234 @@ 4. examine if the player wins / loses / is still alive using `gameState`.  -}+{-# LANGUAGE TupleSections, FlexibleContexts, RankNTypes #-} module Game.H2048.Core-    ( Board-    , Line-    , Dir (..)-    , BoardUpdated (..)-    , GameState (..)-    , gameState-    , compactLine-    , initBoard-    , initGameBoard-    , updateBoard-    , insertNewCell-    , generateNewCell-    )+  ( Dir (..)+  , BoardUpdateResult+  , Board+  , mkBoard+  , fromBoard+  , defBoard+  , Line+  , mkLine+  , defLine+  , gameState+  , GameState(..)+  , compactLine'+  , compactLine+  , initGameBoard+  , updateBoard+  , insertNewCell+  , nextMoves+  ) where -import Control.Arrow-import Control.Monad-import Control.Monad.Writer-import Control.Monad.Random import Data.List import Data.Maybe +import Control.Applicative+import Control.Monad.Writer+import Control.Monad.Random+import Data.Coerce+import Control.Lens+ import Game.H2048.Utils  -- | represent a 4x4 board for Game 2048 --   each element should be either zero or 2^i --   where i >= 1.-type Board = [[Int]]+newtype Board = Board [Line] +data GameState = GS+  { hasWon :: Bool+  , isAlive :: Bool+  } deriving (Eq, Show)++{-+  TODO: I think the problem with current Board & Line is that+  it is too fancy and in some sense restrictive+  for the work it needs to do - all this transposing+  and isomorphism stuff looks nice at first but using lens is really an overkill+  and we don't really have many performance gain to begin with.+  regarding the "restrictive" bit: Line is really just a list of four elements+  and this makes it hard to extend to say 5x5 or non-square board.+  What I want to try is to use a Map structure instead:+  - when collapsing a line, the sequence of coordinates are computed to+    extract the line from board, process as if it is a list of cells+    and write it back afterwards.++  Also I want to try out another idea:+  define `newtype Cell = Cell Int`, where `merge :: Cell -> Cell -> Maybe Cell`+  merges two cell only if two embedding numbers are same (say i)+  and the result is `Just (Cell (i+1))` this saves a little bit space+  and allows us to use stuff other than 1,2,4,8...+ -}+mkBoard :: [[Int]] -> Board+mkBoard = Board . take 4 . (++ repeat defLine) . (mkLine <$>)++fromBoard :: Board -> [[Int]]+fromBoard = coerce+ -- | a list of 4 elements, stands for --   one column / row in the board-type Line  =  [Int]+{-+  Alternatively Line could be a ~ Int => (a,a,a,a)+  and Board being a ~ Line -> (a,a,a,a),+  we should be able to utilize fixed-vector. +  but here we don't have a user-friendly set of tools+  to deal with traversal (at least not that I'm aware of),+  so I guess for now we can still stick to List.+-}+newtype Line = Line [Int] deriving (Eq, Show)++mkLine :: [Int] -> Line+mkLine = Line . take 4 . (++ repeat 0)++defLine :: Line+defLine = mkLine []+ -- | result after a successful 'updateBoard'-data BoardUpdated = BoardUpdated-    { brBoard    :: Board  -- ^ new board-    , brScore    :: Int    -- ^ score collected in this update-    } deriving (Eq, Show)+type BoardUpdateResult = (Board, Int) --- | current game state, see also 'gameState'-data GameState = Win       -- ^ win, can make no step further-               | WinAlive  -- ^ win, and still alive-               | Lose      -- ^ can make no step further, no cell reaches 2048-               | Alive     -- ^ playing-                 deriving (Enum, Eq, Show)+{-+  notice that we don't need GameState at all:+  - at any point in time, the game is won when we have a cell that contains a value+    >= 2048+  - when there are possible moves, we are not done yet,+    otherwise the game is lost. +  therefore we could probably return a list of pairs of+  (<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.+-}+ -- | move direction-data Dir = DUp-         | DDown-         | DLeft-         | DRight-         deriving (Enum, Bounded, Eq, Ord, Show)+data Dir+  = DUp+  | DDown+  | DLeft+  | DRight+  deriving (Enum, Bounded, Eq, Ord, Show) +allDirs :: [Dir]+allDirs = [minBound .. maxBound]+ -- | the initial board before a game started-initBoard :: Board-initBoard = (replicate 4 . replicate 4) 0+defBoard :: Board+defBoard = mkBoard [] +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+ -- | move each non-zero element to their leftmost possible --   position while preserving the order-compactLine :: Line -> Writer (Sum Int) Line-compactLine = runKleisli-                    -- remove zeros-                  ( filter (/=0)-                    -- do merge and collect score-                ^>> Kleisli merge-                    -- restore zeros, on the "fst" part-                >>^ take 4 . (++ repeat 0))--    where-        merge :: [Int] -> Writer (Sum Int) [Int]-        merge (x:y:xs) =-            if x == y-                -- only place where score are collected.-                then do-                    -- try to merge first two elements,-                    -- and process rest of it.-                    xs' <- merge xs-                    tell . Sum $ x + y-                    return $ (x+y) : xs'-                else do-                    -- just skip the first one,-                    -- and process rest of it.-                    xs' <- merge (y:xs)-                    return $ x : xs'-        merge r = return r+compactLine :: MonadWriter (Sum Int) m => Line -> m Line+compactLine l = let (v, l') = compactLine' l in writer (l', v)  -- | update the board taking a direction, --   a 'BoardUpdated' is returned on success, --   if this update does nothing, that means a failure (Nothing)-updateBoard :: Dir -> Board -> Maybe BoardUpdated-updateBoard d board = if board /= board'-                          then Just $ BoardUpdated board' (getSum score)-                          else Nothing-    where-        board' :: Board-        -- transform boards so that-        -- we only focus on "gravitize to the left".-        -- and convert back after the gravitization is done.-        (board',score) = runWriter $-                         runKleisli-                               -- transform to a "gravitize to the left" problem-                             ( rTransL-                               -- gravitize to the left-                           ^>> Kleisli (mapM compactLine)-                               -- transform back-                           >>^ rTransR) board+--   note that here "update" does not include adding one random cell of 2 or 4+--   into the board+updateBoard :: Dir -> Board -> Maybe BoardUpdateResult+updateBoard d (Board board) = do+    guard $ board /= board'+    pure (Board board', getSum score)+  where+    -- transform boards so that+    -- we only focus on "gravitize to the left".+    -- and convert back after the gravitization is done.+    (board',score) = runWriter $ withIso (getIso d) $+      \g f -> g <$> mapM compactLine (f board) -        -- rTrans for "a list of reversible transformations, that will be performed in order"-        rTrans :: [Board -> Board]-        rTrans =-            case d of-              -- the problem itself is "gravitize to the left"-              DLeft  -> []-              -- we use a mirror-              DRight -> [map reverse]-              -- diagonal mirror-              DUp    -> [transpose]-              -- same as DUp case + DRight case-              DDown  -> [transpose, map reverse]+getIso :: Dir -> Iso' [Line] [Line]+getIso d = c . ik . from c+  where+    ik = case d of+      DLeft -> id+      DRight -> sRight+      DUp -> sUp+      DDown -> sRight . sUp+    c :: Iso' [Line] [[Int]]+    c = coerced -        -- how we convert it "into" and "back"-        rTransL = foldl (flip (.)) id rTrans-        rTransR = foldr       (.)  id rTrans+    sRight = involuted (map reverse)+    sUp = involuted transpose +nextMoves :: Board -> [(Dir, BoardUpdateResult)]+nextMoves b = mapMaybe (\d -> (d,) <$> updateBoard d b) allDirs+ -- | find blank cells in a board, --   return coordinates for each blank cell blankCells :: Board -> [(Int, Int)]-blankCells b = map (\(row, (col, _)) -> (row,col)) blankCells'-    where-        blankCells' = filter ((== 0) . snd . snd) linearBoard-        -- flatten to make it ready for filter-        linearBoard = concat $ zipWith tagRow [0..] colTagged+blankCells (Board b) = map (\(row, (col, _)) -> (row,col)) blankCells'+  where+    {-+      the algorithm is to just find all empty cells -+      we could of course keep track of all empty cells,+      but that will be overcomplicated and hard to maintain+      when we do "compactLine"+     -}+    blankCells' = filter ((== 0) . snd . snd) linearBoard+    -- flatten to make it ready for filter+    linearBoard = concat $ zipWith tagRow [0..] colTagged -        -- tag cells with row num-        tagRow row = map ( (,) row )-        -- tag cells with column num-        colTagged = map (zip [0..]) b+    -- tag cells with row num+    tagRow row = map (row,)+    -- tag cells with column num+    colTagged = map (zip [0..] . (coerce :: Line -> [Int])) b --- | return current game state.---   'Win' if any cell is equal to or greater than 2048---   or 'Lose' if we can move no further---   otherwise, 'Alive'. gameState :: Board -> GameState-gameState b-    | isWin-        = if noFurther-              then Win-              else WinAlive-    | noFurther-        = Lose-    | otherwise-        = Alive-    where-        isWin = (any (>= 2048) . concat) b-        noFurther = all (isNothing . ( `updateBoard` b)) universe+gameState nb@(Board b) = GS hw alv+  where+    hw = (any (>= 2048) . concatMap (coerce :: Line -> [Int])) b+    alv = not . null . nextMoves $ nb  -- | initialize the board by puting two cells randomly --   into the board. --   See 'generateNewCell' for the cell generating rule.-initGameBoard :: (MonadRandom r) => r (Board, Int)+initGameBoard :: (MonadRandom m, Alternative m) => m (Board, Int) initGameBoard =     -- insert two cells and return the resulting board     -- here we can safely assume that the board has at least two empty cells     -- so that we can never have Nothing on the LHS-    liftM ( (\x -> (x,0)) . fromJust) (insertNewCell initBoard >>= (insertNewCell . fromJust))+    (,0) . fromJust <$> (insertNewCell defBoard >>= (insertNewCell . fromJust))  -- | try to insert a new cell randomly-insertNewCell :: (MonadRandom r) => Board -> r (Maybe Board)+insertNewCell :: (MonadRandom r, Alternative r) => Board -> r (Maybe Board) insertNewCell b = do     -- get a list of coordinates of blank cells     let availableCells = blankCells b--    if null availableCells-       -- cannot find any empty cell, then fail-       then return Nothing-       else do-           -- randomly pick up an available cell by choosing index-           choice <- getRandomR (0, length availableCells - 1)-           let (row,col) = availableCells !! choice-           value <- generateNewCell-           return $ Just $ (inPos row . inPos col) (const value) b+    guard $ (not . null) availableCells+    -- randomly pick up an available cell by choosing index+    choice <- getRandomR (0, length availableCells - 1)+    let (row,col) = availableCells !! choice+    value <- generateNewCell+    let (Board b') = b+        c1 :: ([Int] -> [Int]) -> Line -> Line+        c1 = coerce+    pure $ Just $ Board $ (inPos row . c1 . inPos col) (const value) b'  -- | generate a new cell according to the game rule --   we have 90% probability of getting a cell of value 2, --   and 10% probability of getting a cell of value 4. generateNewCell :: (MonadRandom r) => r Int-generateNewCell = do-    r <- getRandom-    return $ if r < (0.9 :: Float) then 2 else 4+generateNewCell = getRandom >>= \r ->+    pure $ if r < (0.9 :: Float) then 2 else 4

@@ -0,0 +1,135 @@+{-# LANGUAGE OverloadedStrings, NamedFieldPuns #-}+module Game.H2048.UI.Brick where++import Brick+import Brick.Widgets.Border+import Brick.Widgets.Center+import Data.Bits+import Data.Functor+import Data.List+import Data.String+import Data.Maybe+import Graphics.Vty.Attributes+import Graphics.Vty.Input.Events+import Control.Monad.IO.Class++import Game.H2048.Core++data RName = RBoard deriving (Eq, Ord)++type AppState = (Board, Int {- for tracking total score -})++valToTier :: Int -> Int+valToTier = countTrailingZeros -- tier starting from 1++tierAttr :: Int -> AttrName+tierAttr = ("tier" <>) . fromString . show++boardSample :: Board+boardSample = mkBoard+  [ [1,2,4,8]+  , [16,32,64,128]+  , [256,512,1024,2048]+  , [0,0,0,0]+  ]++boardWidget :: AppState -> Widget RName+boardWidget (bdOpaque, _) =+    joinBorders+    . border+    $ grid+  where+    bd = fromBoard bdOpaque+    grid =+      hLimit (hMax*4+3) $ vBox (intersperse hBorder (row <$> [0..3]))+    row :: Int -> Widget RName+    row r =+      vLimit 1 $+        hBox (intersperse vBorder (cell r <$> [0..3]))+    contentSample = " 2048 " :: String+    hMax = length contentSample+    cell :: Int -> Int -> Widget RName+    cell r c =+      vLimit 1 . hLimit hMax $ cellW+      where+        val = bd !! r !! c+        cellW =+          if val == 0+            then fill ' '+            else+              withAttr (tierAttr . valToTier $ val)+              . padLeft Max+              $ str (show (bd !! r !! c) <> " ")++ui :: AppState -> Widget RName+ui s@(bd,score) =+    center $+      hCenter (boardWidget s)+      <=> hCenter (str $ "Current Score: " <> show score)+      <=> hCenter (str ctrlHelpMsg)+  where+    GS {hasWon, isAlive} = gameState bd+    moveHelp = "i / k / j / l / arrow keys to move, "+    commonHelp = "q to quit, r to restart."+    {- TODO: this starts getting awkward, perhaps time to split the widget. -}+    ctrlHelpMsg =+      if not isAlive+        then+          (if hasWon then "You won, but no more moves. " else "No more moves, game over. ")+          <> commonHelp+        else+          (if hasWon then "You've won! " else "")+          <> moveHelp <> commonHelp++handleEvent :: AppState -> BrickEvent RName e -> EventM RName (Next AppState)+handleEvent s@(bd,score) e = case e of+  VtyEvent (EvKey (KChar 'q') []) -> halt s+  VtyEvent (EvKey (KChar 'r') []) ->+    liftIO initGameBoard >>= continue+  VtyEvent (EvKey k [])+    | Just dir <- getMove k -> case updateBoard dir bd of+        Nothing -> continue s+        Just (bd', awarded) -> do+          bd'' <- fromJust <$> liftIO (insertNewCell bd')+          continue (bd'', score+awarded)+  _ -> continue s++getMove :: Key -> Maybe Dir+getMove KUp = Just DUp+getMove KDown = Just DDown+getMove KLeft = Just DLeft+getMove KRight = Just DRight+getMove (KChar 'i') = Just DUp+getMove (KChar 'k') = Just DDown+getMove (KChar 'j') = Just DLeft+getMove (KChar 'l') = Just DRight+getMove _ = Nothing++main :: IO ()+main = do+  initGb <- initGameBoard+  let app =+        App+        { appDraw = \s -> [ui s]+        , appHandleEvent = handleEvent+        , appStartEvent = pure+        , appAttrMap =+            const $+              attrMap defAttr $+                zip (tierAttr <$> [1..])+                    [ fg (ISOColor 7) `withStyle` dim+                    , fg (ISOColor 6) `withStyle` dim+                    , fg (ISOColor 3) `withStyle` dim+                    , fg (ISOColor 2) `withStyle` dim+                    , fg (ISOColor 1) `withStyle` dim+                    , fg (ISOColor 7) `withStyle` bold+                    , fg (ISOColor 4) `withStyle` bold+                    , fg (ISOColor 6) `withStyle` bold+                    , fg (ISOColor 2) `withStyle` bold+                    , fg (ISOColor 1) `withStyle` bold+                    , fg (ISOColor 3) `withStyle` bold+                    ]+        , appChooseCursor = neverShowCursor+        }+      initState = initGb+  void $ defaultMain app initState

@@ -9,19 +9,22 @@ A simple CLI implemention of Game 2048  -}+{-# LANGUAGE NamedFieldPuns #-} module Game.H2048.UI.Simple-    ( drawBoard-    , playGame-    , mainSimple-    )+  ( drawBoard+  , playGame+  , main+  , Board+  ) where +import Data.Maybe import Game.H2048.Core- import Data.List import Text.Printf import Control.Monad.IO.Class import Control.Monad.Random+import Control.Applicative import Control.Arrow import System.IO @@ -33,9 +36,9 @@  -- | pretty print the board to stdout drawBoard :: Board -> IO ()-drawBoard board = do+drawBoard bd =     {--     when outputed, a cell will look like:+     a cell will be represented in the output as following:         +-----+        | xxx |@@ -48,112 +51,96 @@      * let each cell in the row print " <number> |"      * finalize this line by printing out the horizontal "+--+--+..."     -}-    putStrLn horizSeparator-    mapM_ drawRow board-    where-        cellWidth = length " 2048 "-        -- build up the separator: "+--+--+....+"-        horizSeparator' =-            intercalate "+" (replicate 4 (replicate cellWidth '-'))-        horizSeparator = "+" ++ horizSeparator' ++ "+"--        -- pretty string for a cell (without border)-        prettyCell c = if c == 0-                           then replicate cellWidth ' '-                           else printf " %4d " c+    putStrLn horizSeparator >>+    mapM_ drawRow (fromBoard bd)+  where+    cellWidth = length " 2048 "+    -- build up the separator: "+--+--+....+"+    horizSeparator' = intercalate "+" (replicate 4 (replicate cellWidth '-'))+    horizSeparator = "+" ++ horizSeparator' ++ "+" -        drawRow :: [Int] -> IO ()-        drawRow row = do-            -- prints "| <cell1> | <cell2> | ... |"-            putChar '|'-            mapM_ (prettyCell >>> putStr >>> (>> putChar '|') ) row-            putChar '\n'-            putStrLn horizSeparator+    -- pretty string for a cell (without border)+    prettyCell c =+      if c == 0+        then replicate cellWidth ' '+        else printf " %4d " c+             +    drawRow row = do+      -- prints "| <cell1> | <cell2> | ... |"+      putChar '|'+      mapM_ (prettyCell >>> putStr >>> (>> putChar '|')) row+      putChar '\n'+      putStrLn horizSeparator  -- | play game on a given board until user quits or game ends-playGame :: (RandomGen g) => (Board, Int) -> RandT g IO ()-playGame (b,score) = do-        -- when game over-    let endGame (b',score') win = do-            drawBoard b'-            putStrLn $ if win-                           then "You win"-                           else "Game over"-            _ <- printf "Final score: %d\n" score'-            hFlush stdout-        -- handle user move, print the board together with current score,-        -- return the next user move:-        -- * return Nothing only if user has pressed "q"-        -- * return Just <key>   if one of "ijkl" is pressed-        handleUserMove win = do-            let scoreFormat =-                    if win-                        then "You win, current score: %d\n"-                        else "Current score: %d\n"-            drawBoard b-            _ <- printf scoreFormat score-            hFlush stdout-            c <- getChar-            putStrLn ""-            hFlush stdout--            -- TODO: customizable-            maybeKey <- case c of-                     'q' -> return Nothing-                     'i' -> putStrLn "Up"    >> return (Just DUp)-                     'k' -> putStrLn "Down"  >> return (Just DDown)-                     'j' -> putStrLn "Left"  >> return (Just DLeft)-                     'l' -> putStrLn "Right" >> return (Just DRight)-                     _ -> do-                             putStrLn helpString-                             return $ error "Unreachable code: unhandled invalid user input"--            if c `elem` "qijkl"-               -- user will not be on this branch-               -- if an invalid key is pressed-               then return maybeKey-               -- user will be trapped in "handleUserMove" unless-               -- a valid key is given. So the error above (the wildcard case)-               -- can never be reached-               else handleUserMove win-        handleGame =-            maybe-                -- user quit-                (return ())-                -- user next move-                  -- 1. update the board according to user move-                ((`updateBoard` b) >>>-                  -- 2. the update might succeed / fail-                  maybe-                         -- 2(a). the move is invalid, try again-                         (liftIO (putStrLn "Invalid move") >> playGame (b,score))-                         -- 2(b). on success, insert new cell-                         (\ result -> do-                              -- should always succeed-                              -- because when a successful move is done-                              -- there is at least one empty cell in the board-                              (Just newB) <- insertNewCell (brBoard result)-                              -- keep going, accumulate score-                              playGame (newB, score + brScore result)))--    case gameState b of-      Win ->-          liftIO $ endGame (b,score) True-      Lose ->-          liftIO $ endGame (b,score) False-      WinAlive ->-          liftIO (handleUserMove True ) >>= handleGame-      Alive ->-          liftIO (handleUserMove False) >>= handleGame+playGame :: (MonadIO m, MonadRandom m, Alternative m) => (Board, Int) -> m ()+playGame args@(b,score) |+  GS {hasWon, isAlive} <- gameState b =+    if isAlive+      then liftIO (handleUserMove hasWon) >>= handleGame+      else liftIO (endGame args hasWon)+ where+   endGame (b',score') win = do+     drawBoard b'+     putStrLn $ if win then "You won" else "Game over"+     _ <- printf "Final score: %d\n" score'+     hFlush stdout+   -- handle user move, print the board together with current score,+   -- return the next user move:+   -- + return Nothing only if user has pressed "q"+   -- + return Just <key>   if one of "ijkl" is pressed+   handleUserMove w = fix $ \self -> do+     let scoreFormat =+           if w+             then "You win, current score: %d\n"+             else "Current score: %d\n"+     drawBoard b+     _ <- printf scoreFormat score+     hFlush stdout+     c <- getChar+     putStrLn ""+     hFlush stdout+     -- TODO: customizable+     case c of+       'q' -> pure Nothing+       'i' -> putStrLn "Up"    >> pure (Just DUp)+       'k' -> putStrLn "Down"  >> pure (Just DDown)+       'j' -> putStrLn "Left"  >> pure (Just DLeft)+       'l' -> putStrLn "Right" >> pure (Just DRight)+       _ -> do+         -- user will not be on this branch+         -- if an invalid key is pressed+         putStrLn helpString+         self+   handleGame =+     maybe+       -- user quit+       (pure ())+       -- user next move+       -- 1. update the board according to user move+       ((`updateBoard` b) >>>+         -- 2. the update might succeed / fail+         maybe+           -- 2(a). the move is invalid, try again+           (liftIO (putStrLn "Invalid move") >> playGame args)+           -- 2(b). on success, insert new cell+           (\(newBoard, scoreObtained) -> do+               -- should always succeed+               -- because when a successful move is done+               -- there is at least one empty cell in the board+               newB <- fromJust <$> insertNewCell newBoard+               -- keep going, accumulate score+               playGame (newB, score + scoreObtained)))  -- | the entry of Simple UI-mainSimple :: IO ()-mainSimple = do+main :: IO ()+main = do     bfMod <- hGetBuffering stdin     -- no buffering - don't wait for the "enter"     hSetBuffering stdin NoBuffering     g <- newStdGen-    -- in case someone don't read the README+    -- show some helpful messages+    -- whether the user has read the README or not :)     putStrLn helpString     -- initialize game based on the random seed     _ <- evalRandT (initGameBoard >>= playGame) g

@@ -1,207 +0,0 @@-{-|-  Module      : Game.H2048.UI.Vty-  Copyright   : (c) 2014 Javran Cheng-  License     : MIT-  Maintainer  : Javran.C@gmail.com-  Stability   : experimental-  Portability : POSIX--A CLI version of Game 2048 implemented using vty-ui---}-{-# LANGUAGE OverloadedStrings #-}-module Game.H2048.UI.Vty-    ( PlayState (..)-    , mainVty-    )-where--import Graphics.Vty.Widgets.All-import Graphics.Vty-import qualified Data.Text as T-import Control.Monad-import Control.Monad.Random-import Data.Foldable (foldMap)-import Data.IORef-import Data.Maybe--import Game.H2048.Core---- | indicate the status of a playing session-data PlayState g = PlayState-    { psBoard  :: Board     -- ^ current board-    , psScore  :: Int       -- ^ current collected score-    , psGState :: GameState -- ^ indicate whether the game terminates-    , psRGen   ::  g        -- ^ next random generator-    }---- | flatten a 2D list, and keep the original---   coordinate with the actual value, each element---   in the resulting list looks like @({value},({row index},{colum index}))@.-toIndexedBoard :: Board -> [(Int, (Int, Int))]-toIndexedBoard b = concat $ zipWith go [0..] taggedCols-    where-        -- board with each cell tagged with its col num-        taggedCols = map (zip [0..]) b-        go :: Int -> [(Int,Int)] -> [(Int,(Int,Int))]-        go row = map (\(col,val) -> (val,(row,col)))---- | calculate colors and styles for a given number-colorize :: Int -> [(T.Text, Attr)]-colorize i = [(s,attr)]-    where-        s = if i /= 0 then (T.pack . show) i else " "-        attr = Attr (SetTo colorSty) (SetTo colorNum) Default-        (colorSty, colorNum) = fromMaybe (bold,ISOColor 3) (lookup i colorDict)-        colorDict =-            [ (   0, (  dim, ISOColor 0))-            , (   2, (  dim, ISOColor 7))-            , (   4, (  dim, ISOColor 6))-            , (   8, (  dim, ISOColor 3))-            , (  16, (  dim, ISOColor 2))-            , (  32, (  dim, ISOColor 1))-            , (  64, ( bold, ISOColor 7))-            , ( 128, ( bold, ISOColor 4))-            , ( 256, ( bold, ISOColor 6))-            , ( 512, ( bold, ISOColor 2))-            , (1024, ( bold, ISOColor 1))-            , (2048, ( bold, ISOColor 3))-            ]---- | render UI according to the PlayState-renderGame :: PlayState g              -- ^ the PlayState-           -> [[Widget FormattedText]] -- ^ cell widgets-           -> Widget FormattedText     -- ^ status bar widget-           ->  IO ()-renderGame (PlayState bd sc gs _) items st = do-    let ixBd = toIndexedBoard bd-        renderCell v (row,col) = do-            let item = items !! row !! col-            -- for each cell, colorize it-            -- and update the corresponding widget-            item `setTextWithAttrs` colorize v-        -- the beginning of status bar-        scoreDesc = case gs of-                      Win -> "You win. Final score: "-                      Lose -> "Game over. Final score: "-                      Alive -> "Current score: "-                      WinAlive -> "You win, current score:"--    -- update table-    mapM_ (uncurry renderCell) ixBd-    -- update status bar-    setText st $ T.pack (scoreDesc ++ show sc)---- | perform game update when a new direction is given-newDirGameUpdate :: (RandomGen g)-                 => IORef (PlayState g)      -- ^ where PlayState is held-                 -> [[Widget FormattedText]] -- ^ cell widgets-                 -> Widget FormattedText     -- ^ status bar-                 -> Dir                      -- ^ new direction-                 -> IO Bool-newDirGameUpdate psR items st dir = do-    (PlayState b1 s1 gs1 g1) <- readIORef psR-    let updated = updateBoard dir b1-        onSuccessUpdate (BoardUpdated b2 newS2) = do-            -- if we are still alive, this insertion is always possible,-            -- because a successful update means at least two cells-            -- are merged together, leaving at least one empty cell-            (Just b3,g2) <- runRandT (insertNewCell b2) g1-            -- create new PlayState, collect score, sync GameState-            let ps2 = PlayState b3 (s1 + newS2) (gameState b3) g2-            renderGame ps2 items st-            -- update PlayState to the IORef-            writeIORef psR ps2-            return True-        onAlive =-            maybe-                -- 2(a). update failed, invalid move, do nothing-                (return True)-                -- 2(b). updated successfully-                onSuccessUpdate-                -- 2. try to update the board-                updated--    -- 1. only update if alive-    case gs1 of-      Win ->-          return True-      Lose ->-          return True-      Alive ->-          onAlive-      WinAlive ->-          onAlive---- | the entry for vty-ui CLI implementation-mainVty :: IO ()-mainVty = do-    let cellSample :: String-        cellSample = " 2048 "-        cellLen = length cellSample-        -- spec for a single cell-        -- e.g.:-        cellSpec = ColumnSpec (ColFixed cellLen)-                              (Just AlignRight)-                              (Just (padRight 1))-        helpString = "'i'/'k'/'j'/'l'/arrow keys to move, 'q' to quit."--    -- build up UI-    tbl <- newTable (replicate 4 cellSpec) BorderFull--    pScore <- plainText " <Score> "-    pHelp  <- plainText helpString-    hints  <- hCentered pScore <--> hCentered pHelp-    allW   <- hCentered tbl <--> return hints-    ui     <- centered allW--    fg <- newFocusGroup-    _  <- addToFocusGroup fg pScore--    -- the argument to plainText cannot be an empty string-    -- otherwise the output would be weird-    items  <- (replicateM 4 . replicateM 4) (plainText " ")--    mapM_ (addRow tbl . foldMap mkRow) items--    -- prepare data and initialize-    g <- newStdGen-    ((bd,s),g') <- runRandT initGameBoard g--    -- keep track of playing state using IORef-    let ps = PlayState bd s Alive g'-    playStateR <- newIORef ps--    -- first rendering-    renderGame ps items pScore--    c <- newCollection-    _ <- addToCollection c ui fg--    -- shorthand for event update-    let doUpdate = newDirGameUpdate playStateR items pScore--    pScore `onKeyPressed` \_ key _ ->-        case key of-          KChar 'q' ->-              shutdownUi >> return True-          KChar 'i' ->-              doUpdate DUp-          KUp ->-              doUpdate DUp-          KChar 'k' ->-              doUpdate DDown-          KDown ->-              doUpdate DDown-          KChar 'j' ->-              doUpdate DLeft-          KLeft ->-              doUpdate DLeft-          KChar 'l' ->-              doUpdate DRight-          KRight ->-              doUpdate DRight-          _ ->-              return False--    runUi c defaultContext

@@ -10,16 +10,11 @@  -} module Game.H2048.Utils-    ( inPos-    , universe-    )+  ( inPos+  ) where --- provide utilities---- | all possible values for a Bounded Enum-universe :: (Bounded e, Enum e) => [e]-universe = [minBound .. maxBound]+import Control.Lens  -- | modify a specified element in a list, --   this is a simple semantic editor combinator@@ -27,12 +22,4 @@       -> (a -> a) -- ^ a function from the old element to the new one       -> [a]      -- ^ the list to be modified       -> [a]-inPos n f xs-      | null xs    = xs-      | n < 0      = xs-      -- for all the cases below,-      -- safely assume n >= 0 and xs is not empty-      | n == 0     = let (y:ys) = xs-                     in f y : ys-      | otherwise  = let (y:ys) = xs-                     in y : inPos (n - 1) f ys+inPos n = over (ix n)

@@ -1,7 +0,0 @@-module Main-where--import Game.H2048.UI.Simple--main :: IO ()-main = mainSimple

@@ -1,7 +0,0 @@-module Main-where--import Game.H2048.UI.Vty--main :: IO ()-main = mainVty

@@ -1,88 +0,0 @@-import Test.HUnit--import Control.Arrow-import Control.Monad-import Control.Monad.Writer-import System.Exit--import Game.H2048.Core---- | the expected behavior of 'compactLine'-compactLineTestcases :: [ ((Line, Int) , Line) ]-compactLineTestcases =-    --  < expected  >   < input >-    [ ( ([0,0,0,0],0),  [0,0,0,0] )-    , ( ([2,0,0,0],2),  [1,0,0,1] )-    , ( ([4,4,0,0],8),  [2,2,2,2] )-    , ( ([2,8,2,0],8),  [2,4,4,2] )-    , ( ([2,4,8,2],0),  [2,4,8,2] )-    , ( ([2,0,0,0],2),  [0,1,0,1] )-    , ( ([1,2,0,0],0),  [1,0,2,0] )-    ]--compactLineTests :: Test-compactLineTests = TestLabel "compactLine" . TestList . map-        (\(expected, inp) ->-             expected ~=?-             second getSum (runWriter (compactLine inp)))-        $ compactLineTestcases---- | the expected behavior of 'gameState'-gameStateTestcases :: [ (String, GameState, Board) ]-gameStateTestcases =-    [ ( "trivial win, alive",-        WinAlive , [ [ 2048, 2048, 2048, 2048 ]-                   , [    0,    0,    0,    0 ]-                   , [    0,    0,    0,    0 ]-                   , [    0,    0,    0,    0 ] ] )-    , ( "more than 2048 (might not happen in practice)",-        Win      , [ [  256,    2,    4,    8 ]-                   , [   16,   32,   64,  128 ]-                   , [  256,  512, 1024,    8 ]-                   , [   16, 4096,  128,   64 ] ] )-    , ( "no more move but win",-        Win      , [ [    2,    4,    2,    4 ]-                   , [    4, 2048,    4,    2 ]-                   , [    2,    4,    2,    4 ]-                   , [    4,    2,    4,    2 ] ] )-    , ( "trivial alive",-        Alive    , [ [    2,    0,    0,    8 ]-                   , [    4,    0,    0,    8 ]-                   , [    4,    0,    0,    8 ]-                   , [ 1024,  512,  128,   64 ] ] )-    , ( "no empty cell but still alive",-        Alive    , [ [  512,  128,  512,  128 ]-                   , [  128,  512,  128,  512 ]-                   , [  512,  128,  512,  128 ]-                   , [  128,  512,  128,  128 ] ] )-    , ( "trivial lose 1",-        Lose     , [ [    2,    4,    2,    4 ]-                   , [    4,    2,    4,    2 ]-                   , [    2,    4,    2,    4 ]-                   , [    4,    2,    4,    2 ] ] )-    , ( "trivial lose 2",-        Lose     , [ [    2,    8,   32,    2 ]-                   , [    4,    2,    8,    4 ]-                   , [   32,   16,  128,   16 ]-                   , [    4,    8,    4,    2 ] ] )-    ]--gameStateTests :: Test-gameStateTests = TestLabel "gameState" . TestList . map-        (\(lbl, expected, inp) ->-             TestLabel lbl (expected ~=? gameState inp))-        $ gameStateTestcases---- | run testcase and quit immediately after a failure-runTestFailIm :: Test -> IO ()-runTestFailIm t = do-    cs <- runTestTT t-    print cs-    when (errors cs > 0 || failures cs > 0)-         exitFailure--main :: IO ()-main = mapM_ runTestFailIm-       [ compactLineTests-       , gameStateTests-       ]

@@ -0,0 +1,78 @@+module Game.H2048.CoreSpec where++import Test.Hspec++import Game.H2048.Core++spec :: Spec+spec = do+  describe "compactLine" $+    specify "examples" $ do+      let clTest inp expected =+              compactLine' (mkLine inp)+                `shouldBe` (eScore, mkLine eLine)+            where+              (eScore, eLine) = expected+      clTest [0,0,0,0] (0,[0,0,0,0])+      clTest [1,0,0,1] (2,[2,0,0,0])+      clTest [2,2,2,2] (8,[4,4,0,0])+      clTest [2,4,4,2] (8,[2,8,2,0])+      clTest [2,4,8,2] (0,[2,4,8,2])+      clTest [0,1,0,1] (2,[2,0,0,0])+      clTest [1,0,2,0] (0,[1,2,0,0])++  describe "gameState" $ do+    let gWonAlive = GS True True+        gWon = GS True False+        gAlive = GS False True+        gLose = GS False False+        gameState' = gameState . mkBoard+    specify "trivial win, alive" $+      gameState'+        [ [ 2048, 2048, 2048, 2048 ]+        , [    0,    0,    0,    0 ]+        , [    0,    0,    0,    0 ]+        , [    0,    0,    0,    0 ]+        ] `shouldBe` gWonAlive+    specify "more than 2048 (might not happen in practice)" $+      gameState'+        [ [  256,    2,    4,    8 ]+        , [   16,   32,   64,  128 ]+        , [  256,  512, 1024,    8 ]+        , [   16, 4096,  128,   64 ]+        ] `shouldBe` gWon+    specify  "no more move but win" $+      gameState'+        [ [    2,    4,    2,    4 ]+        , [    4, 2048,    4,    2 ]+        , [    2,    4,    2,    4 ]+        , [    4,    2,    4,    2 ]+        ] `shouldBe` gWon+    specify "trivial alive" $+      gameState'+        [ [    2,    0,    0,    8 ]+        , [    4,    0,    0,    8 ]+        , [    4,    0,    0,    8 ]+        , [ 1024,  512,  128,   64 ]+        ] `shouldBe` gAlive+    specify "no empty cell but still alive" $+      gameState'+        [ [  512,  128,  512,  128 ]+        , [  128,  512,  128,  512 ]+        , [  512,  128,  512,  128 ]+        , [  128,  512,  128,  128 ]+        ] `shouldBe` gAlive+    specify "trivial lose 1" $+      gameState'+        [ [    2,    4,    2,    4 ]+        , [    4,    2,    4,    2 ]+        , [    2,    4,    2,    4 ]+        , [    4,    2,    4,    2 ]+        ] `shouldBe` gLose+    specify "trivial lose 2" $+      gameState'+        [ [    2,    8,   32,    2 ]+        , [    4,    2,    8,    4 ]+        , [   32,   16,  128,   16 ]+        , [    4,    8,    4,    2 ]+        ] `shouldBe` gLose

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}