diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,24 @@ +The MIT License (MIT) + +2048 game logic copyright (c) Josh Kirklin +Gloss rendering code copyright (c) Maia Werbos +Copyright (c) 2015 Konstantin Saveljev + +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,38 @@ +# 2048 game clone using Yampa FRP library + +After trying to grasp the idea of FRP (mostly concentrating on Yampa library) I +have finally found myself understanding it enough to write something simple. + +![yampa-2048 using Gloss](http://ksaveljev.github.io/2048.gif) + +This project is based on some code by other people. I wasn't interested in +implementing the logic of 2048 myself or drawing to Gloss window from scratch. +As a result this repository contains some chunks of the code written by other +people: + +[Josh Kirklin](https://github.com/ScrambledEggsOnToast) and his [excellent +implementation of 2048 in Elm](https://github.com/ScrambledEggsOnToast/2048-elm) + provided me with the game logic. + +[Maia Werbos](https://github.com/tigrennatenn) and her [great implementation of +2048 using Gloss](https://github.com/tigrennatenn/2048haskell) provided me +with the rendering chunk of code. + +I was able to come up with my solution after reading the code by +[Keera Studios](https://github.com/keera-studios) and their [amazing Haskanoid +project](https://github.com/ivanperez-keera/haskanoid) + +Running: + + cabal sandbox init + cabal install --dependencies-only + cabal run + +The gameplay is pretty simple. Nothing fancy. Try to survive for as long as +possible. + +Things I would like to change but probably won't: +- Gloss lacks the ability to style the font, therefore those numbers don't look + nice but as long as works it seems to be ok +- I wanted the game to exit upon the Esc button press but didn't bother to + investigate why it is not closing or how to do it 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/src/Game.hs b/src/Game.hs new file mode 100644 --- /dev/null +++ b/src/Game.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE Arrows #-} + +module Game (wholeGame) where + +import System.Random (StdGen) +import FRP.Yampa + +import Types +import GameModel +import GameLogic + +-- | Run the game that still has moves ('gameAlive'), until ('switch') +-- there are no more moves ('outOfMoves'), in which case the game is over +-- and needs to be restarted ('restartGame') +wholeGame :: StdGen -> SF GameInput GameState +wholeGame g = switch + (gameAlive g >>> (identity &&& outOfMoves)) + (restartGame g) + +-- | Detect when there are no more possible moves on the given board +outOfMoves :: SF GameState (Event GameState) +outOfMoves = proc s -> do + lost <- edge -< isGameOver s + let snapshot = lost `tag` s + returnA -< snapshot + +-- | Start the game using the initial game state (empty board with score 0) +-- and placing two initial tiles randomly onto the board +gameAlive :: StdGen -> SF GameInput GameState +gameAlive g = + let (float1, g') = random g + (float2, g'') = random g' + (float3, g''') = random g'' + (float4, g'''') = random g''' + in runGame $ placeRandomTile float1 float2 + $ placeRandomTile float3 float4 + (initialGameState g'''') + +-- | When the game is lost we want to show the GameOver text for some time +-- and then restart the game +restartGame :: StdGen -> GameState -> SF GameInput GameState +restartGame g s = switch + (gameOver s &&& after 5 ()) + (const $ wholeGame g) + +-- | When we have lost the game we want to keep the board in a state that +-- the user reached and show some GameOver message over it +gameOver :: GameState -> SF a GameState +gameOver s = arr $ const $ s { status = GameOver } + +-- | Run the game, keeping the internal state using dHold, updating the +-- game state based on user's input (if any) +runGame :: GameState -> SF GameInput GameState +runGame state = proc input -> do + rec currentState <- dHold state -< gameUpdated + gameUpdated <- arr update -< (currentState, input) + + returnA -< currentState + +-- | Based on the input received either try to slide the board in the given +-- direction or do not do anything (NoEvent). If the sliding in the given +-- direction is not possible then we are once again not doing anything +-- (NoEvent) +update :: (GameState, GameInput) -> Event GameState +update (gameState, input) = + case input of + Event None -> NoEvent + Event direction -> + let newBoardScore = slideBoard direction (board gameState) + (float1, gen') = random (gen gameState) + (float2, gen'') = random gen' + in if fst newBoardScore == board gameState + then NoEvent + else Event $ placeRandomTile float1 float2 + $ gameState { board = fst newBoardScore + , score = score gameState + snd newBoardScore + , gen = gen'' + } + _ -> NoEvent diff --git a/src/GameLogic.hs b/src/GameLogic.hs new file mode 100644 --- /dev/null +++ b/src/GameLogic.hs @@ -0,0 +1,117 @@ +module GameLogic ( placeRandomTile + , slideBoard + , isGameOver + ) where + +import Prelude ((==), (/=), (>), (*), (<), fromIntegral, floor, fst, snd, ($), Float, Int, Bool, Eq, error) +import Data.List (and, length, sum, filter, concat, (++), replicate, take, (!!)) +import Data.Maybe (Maybe(..), isNothing, fromMaybe) +import Data.Functor (fmap) +import Control.Applicative ((<$>)) +import Control.Category ((.), id) + +import Types +import GameModel + +-- | The probably that a new tile is a 2. What remains here is 0.1 +-- probability to get a 4 as a new tile +tile2Probability :: Float +tile2Probability = 0.9 + +-- | Based on the random value provided we create a new tile which might be +-- either 2 or 4 +newTile :: Float -> Tile +newTile x = Number $ if x < tile2Probability then 2 else 4 + +-- | Find all empty tiles on the board and return them as a list of their +-- coordinates +emptyTiles :: Board -> [(Row, Column)] +emptyTiles b = fmap (\(_, r, c) -> (r, c)) + $ filter (\(tile, _, _) -> tile == Empty) + $ tilesWithCoordinates b + +-- | Return a random (based on input Float) tile (its coordinates on +-- a board) if it is possible. There might be a situation when the game +-- board is full of tiles but the game is not yet over +newTileIndex :: Float -> Board -> Maybe (Row, Column) +newTileIndex x b = + let emptyTileIndices = emptyTiles b + in case emptyTileIndices of + [] -> Nothing + _ -> Just $ emptyTileIndices !! floor (fromIntegral (length emptyTileIndices) * x) + +-- | Place random tile into a random position on a board. Randomness +-- depends on the input Floats +placeRandomTile :: Float -> Float -> GameState -> GameState +placeRandomTile float1 float2 gameState = + let tileIndex = newTileIndex float1 (board gameState) + in if isNothing tileIndex + then gameState + else gameState { board = setTile (fromMaybe (0, 0) tileIndex) (board gameState) $ newTile float2 } + +-- | Takes a list of values and 'slides' them to the left, joining in lists +-- of pairs of adjacent identical values +-- +-- groupedByTwo ["a","b","b","b","c","d","c","c","c","c"] = +-- [["a"],["b","b"],["b"],["c"],["d"],["c","c"],["c","c"]] +-- +-- groupedByTwo [1, 1, 1] = [[1, 1], [1]] +groupedByTwo :: Eq a => [a] -> [[a]] +groupedByTwo l = case l of + [x] -> [[x]] + [x, y] -> if x == y then [[x, y]] else [[x], [y]] + (x:y:xs) -> if x == y + then [x, y] : groupedByTwo xs + else [x] : groupedByTwo (y : xs) + _ -> [] + +-- | Slides list of tiles to the left, merging tiles where necessary, and +-- returning a full list of four tiles, and the number of points gained +slideRow :: [Tile] -> ([Tile], Int) +slideRow row = let grouped = groupedByTwo $ filter (/= Empty) row + in ( take 4 + $ fmap (intToTile . sum . fmap tileToInt) grouped ++ replicate 4 Empty + , sum . fmap tileToInt $ concat $ filter (\x -> length x > 1) grouped + ) + +-- | Slide all of the rows (or columns) of the board in a certain direction +slideBoard :: Direction -> Board -> (Board, Int) +slideBoard direction b = + let rotatedBoard = (case direction of + Down -> rotateBoard + Right -> rotateBoard . rotateBoard + Up -> rotateBoard . rotateBoard . rotateBoard + Left -> id + _ -> error "unexpected direction") b + + rowsWithScores = slideRow <$> (\(Board x) -> x) rotatedBoard + + slidRotatedBoard = Board $ fmap fst rowsWithScores + scoreGained = sum $ fmap snd rowsWithScores + + slidBoard = (case direction of + Up -> rotateBoard + Right -> rotateBoard . rotateBoard + Down -> rotateBoard . rotateBoard . rotateBoard + Left -> id + _ -> error "unexpected direction") slidRotatedBoard + + in (slidBoard, scoreGained) + +-- | Check if the game is over. Conditions are simple: it is not an empty +-- board and 'sliding' the board into any direction doesn't result in +-- different board. Although it might be easier to check if the score of +-- 'sliding' is 0 instead of comparing the boards +isGameOver :: GameState -> Bool +isGameOver gameState = + let b = board gameState + slidUp = fst $ slideBoard Up b + slidDown = fst $ slideBoard Down b + slidLeft = fst $ slideBoard Left b + slidRight = fst $ slideBoard Right b + in and [ b /= emptyBoard + , slidUp == slidDown + , slidDown == slidLeft + , slidLeft == slidRight + , slidRight == b + ] diff --git a/src/GameModel.hs b/src/GameModel.hs new file mode 100644 --- /dev/null +++ b/src/GameModel.hs @@ -0,0 +1,64 @@ +module GameModel ( emptyBoard + , initialGameState + , rotateBoard + , setTile + , tileToInt + , intToTile + , tilesWithCoordinates + , readTile + ) where + +import System.Random (StdGen) +import Data.List (transpose) +import Control.Applicative ((<$>)) + +import Types + +-- | Given a Board we return a tile which can be found on a given row and +-- column +readTile :: (Row, Column) -> Board -> Tile +readTile (row, column) (Board b) = (b !! row) !! column + +-- | Set tile on a given board to a given row and column +setTile :: (Row, Column) -> Board -> Tile -> Board +setTile (row, column) (Board b) tile = + let r = b !! row + nr = take column r ++ [tile] ++ drop (column + 1) r + in Board $ take row b ++ [nr] ++ drop (row + 1) b + +-- | Convert a tile to the int it represents. Empty tile is treated like 0 +tileToInt :: Tile -> Int +tileToInt tile = case tile of + Number v -> v + Empty -> 0 + +-- | Convert an int into a tile representing it. 0 is treated like Empty +-- tile +intToTile :: Int -> Tile +intToTile n = case n of + 0 -> Empty + _ -> Number n + +-- | Convert a board into a list of all tiles with their respective +-- coordinates +tilesWithCoordinates :: Board -> [(Tile, Row, Column)] +tilesWithCoordinates (Board b) = concat + $ zipWith (\rowIndex row -> fmap (\(tile, columnIndex) -> (tile, rowIndex, columnIndex)) row) [0..] + $ fmap (\row -> zip row [0..]) + b + +-- | Rotate given board clockwise by 90 degrees +rotateBoard :: Board -> Board +rotateBoard (Board b) = Board $ reverse <$> transpose b + +-- | A board of empty tiles +emptyBoard :: Board +emptyBoard = Board $ replicate 4 $ replicate 4 Empty + +-- | Default starting game state without 2 initial tiles +initialGameState :: StdGen -> GameState +initialGameState g = GameState { board = emptyBoard + , score = 0 + , status = InProgress + , gen = g + } diff --git a/src/Graphics/Gloss/Interface/FRP/Yampa.hs b/src/Graphics/Gloss/Interface/FRP/Yampa.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Gloss/Interface/FRP/Yampa.hs @@ -0,0 +1,36 @@ +module Graphics.Gloss.Interface.FRP.Yampa (playYampa, InputEvent) where + +import Control.Monad (when) +import Data.IORef (newIORef, writeIORef, readIORef) +import Graphics.Gloss (Display, Color, Picture, blank) +import Graphics.Gloss.Interface.IO.Game (playIO) +import FRP.Yampa (Event(..), SF, reactInit, react) + +import Types (InputEvent) + +-- | Play the game in a window, updating when the value of the provided +playYampa :: Display -- ^ The display method + -> Color -- ^ The background color + -> Int -- ^ The refresh rate, in Hertz + -> SF (Event InputEvent) Picture + -> IO () +playYampa display color frequency mainSF = do + picRef <- newIORef blank + + handle <- reactInit + (return NoEvent) + (\_ updated pic -> when updated (picRef `writeIORef` pic) >> return False) + mainSF + + playIO display + color + frequency + 0 + (const $ readIORef picRef) -- An action to convert the world to a picture + (\e t -> react handle (delta, Just (Event e)) >> return (t + delta)) -- A function to handle input events + (\d t -> let delta' = realToFrac d - t + in if delta' > 0 + then react handle (delta', Just NoEvent) >> return 0.0 + else return (-delta')) -- A function to step the world one iteration. It is passed the period of time (in seconds) needing to be advanced + where + delta = 0.01 / fromIntegral frequency diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,42 @@ +import System.Random (newStdGen, StdGen) +import Graphics.Gloss +import qualified Graphics.Gloss.Interface.IO.Game as G +import Graphics.Gloss.Interface.FRP.Yampa +import FRP.Yampa (Event(..), SF, arr, tag, (>>>)) + +import Types +import Game +import Rendering + +-- | Our game uses up, down, left and right arrows to make the moves, so +-- the first thing we want to do is to parse the Gloss Event into something +-- we are happy to work with (Direction data type) +parseInput :: SF (Event InputEvent) GameInput +parseInput = arr $ \event -> + case event of + Event (G.EventKey (G.SpecialKey G.KeyUp) G.Down _ _) -> event `tag` Types.Up + Event (G.EventKey (G.SpecialKey G.KeyDown) G.Down _ _) -> event `tag` Types.Down + Event (G.EventKey (G.SpecialKey G.KeyLeft) G.Down _ _) -> event `tag` Types.Left + Event (G.EventKey (G.SpecialKey G.KeyRight) G.Down _ _) -> event `tag` Types.Right + _ -> event `tag` None + +-- | After parsing the game input and reacting to it we need to draw the +-- current game state which might have been updated +drawGame :: SF GameState Picture +drawGame = arr drawBoard + +-- | Our main signal function which is responsible for handling the whole +-- game process, starting from parsing the input, moving to the game logic +-- based on that input and finally drawing the resulting game state to +-- Gloss' Picture +mainSF :: StdGen -> SF (Event InputEvent) Picture +mainSF g = parseInput >>> wholeGame g >>> drawGame + +main :: IO () +main = do + g <- newStdGen + playYampa + (InWindow "2048 game" (410, 500) (200, 200)) + white + 30 + (mainSF g) diff --git a/src/Rendering.hs b/src/Rendering.hs new file mode 100644 --- /dev/null +++ b/src/Rendering.hs @@ -0,0 +1,115 @@ +module Rendering (drawBoard) where + +import Graphics.Gloss + +import GameModel +import Types + +rowHeight :: Float +rowHeight = 100 + +tilePrecision :: Int +tilePrecision = 10 + +tileS :: Float +tileS = 90 + +tileRoundness :: Float +tileRoundness = 4 + +textScale :: Float +textScale = 0.2 + +tileBackColor :: Color +tileBackColor = makeColorI 205 192 180 255 + +roundedRect :: Int -> Float -> Float -> Float -> Picture +roundedRect n w h r = pictures [ drawQuarterRoundedRect n w h r + , rotate 90 $ drawQuarterRoundedRect n w h r + , rotate 180 $ drawQuarterRoundedRect n w h r + , rotate 270 $ drawQuarterRoundedRect n w h r + ] + +getPoint :: Float -> Float -> Float -> Float -> (Float,Float) +getPoint x y r th = (x+r*cos th, y+r*sin th) + +arcPath :: Int -> (Float,Float) -> Float -> Path +arcPath n (x,y) r = map (getPoint x y r) $ 0.0 : map (\v -> pi / 2 / fromIntegral v) (reverse [1..n+1]) + +quarterRoundedRect :: Int -> Float -> Float -> Float -> Path +quarterRoundedRect n w h r = [(0,0), (0,h/2)] + ++ reverse (arcPath n (w / 2 - r, h / 2 - r) r) + ++ [(w/2,0)] + +drawQuarterRoundedRect :: Int -> Float -> Float -> Float -> Picture +drawQuarterRoundedRect n w h r = polygon $ quarterRoundedRect n w h r + +drawTileBack :: Float -> Picture +drawTileBack x = color tileBackColor (translate x 0 (roundedRect tilePrecision tileS tileS tileRoundness)) + +-- Takes x-offset and tile and draws the tile itself +drawTile :: Float -> Tile -> Picture +drawTile x tile = + let background = [color (tileColor tile) $ roundedRect tilePrecision tileS tileS tileRoundness] + number = if tileToInt tile > 0 + then [translate (-20) (-10) $ scale textScale textScale $ text $ show $ tileToInt tile] + else [] + curScale = 1 + in pictures [ drawTileBack x + , translate x 0 $ scale curScale curScale $ pictures $ background ++ number + ] + +drawRow :: [Tile] -> Picture +drawRow tile = + let [i, j, k, l] = tile + in translate (-300) 0 (pictures [ drawTile 0 i + , drawTile rowHeight j + , drawTile (rowHeight * 2) k + , drawTile (rowHeight * 3) l + ]) + +gameOverMessage :: Picture +gameOverMessage = pictures [ translate (-500) (-500) $ color translucentWhite $ rectangleSolid 2000 2000 + , translate (-335) (-150) $ scale 0.5 0.5 $ color black $ text "Game Over" + ] + where translucentWhite = makeColorI 255 255 255 150 + +-- | Draw current board representation depending on the status of the game. +-- All tiles will be drawn at all tiles and game over message is drawn onto +-- the game board when game status is GameOver +drawBoard :: GameState -> Picture +drawBoard gameState = + let (Board b) = board gameState + [r1, r2, r3, r4] = b + in translate 150 150 + $ pictures + $ [ drawRow r1 + , translate 0 (-rowHeight) (drawRow r2) + , translate 0 (-rowHeight * 2) (drawRow r3) + , translate 0 (-rowHeight * 3) (drawRow r4) + , translate (-300) 60 $ scale 0.2 0.2 $ color white $ text $ "Score: " ++ show (score gameState) + ] ++ gameOverPicture + where gameOverPicture = [gameOverMessage | status gameState == GameOver] + +-- | Tile colors up to tile with value 2048 taken directly from the +-- original game. The rest of the numbers should be assigned some good +-- values (well we can easily reach tile 4096 and some AI reach 32768) +tileColor :: Tile -> Color +tileColor tile = case tile of + Number 2 -> makeColorI 238 228 218 255 + Number 4 -> makeColorI 237 224 200 255 + Number 8 -> makeColorI 242 177 121 255 + Number 16 -> makeColorI 245 149 99 255 + Number 32 -> makeColorI 246 124 95 255 + Number 64 -> makeColorI 246 94 59 255 + Number 128 -> makeColorI 237 207 114 255 + Number 256 -> makeColorI 237 204 97 255 + Number 512 -> makeColorI 237 200 80 255 + Number 1024 -> makeColorI 237 197 63 255 + Number 2048 -> makeColorI 237 194 46 255 + Number 4096 -> makeColorI 237 194 46 255 -- TODO: needs appropriate color + Number 8192 -> makeColorI 237 194 46 255 -- TODO: needs appropriate color + Number 16384 -> makeColorI 237 194 46 255 -- TODO: needs appropriate color + Number 32768 -> makeColorI 237 194 46 255 -- TODO: needs appropriate color + Number 65536 -> makeColorI 237 194 46 255 -- TODO: needs appropriate color + _ -> makeColorI 238 228 218 90 diff --git a/src/Types.hs b/src/Types.hs new file mode 100644 --- /dev/null +++ b/src/Types.hs @@ -0,0 +1,39 @@ +module Types ( InputEvent + , Tile(..) + , Row + , Column + , Board(..) + , GameState(..) + , GameStatus(..) + , Direction(..) + , GameInput + ) where + +import System.Random (StdGen) +import FRP.Yampa (Event) +import qualified Graphics.Gloss.Interface.IO.Game as G + +-- | A usefule type synonym for Gloss event values, to avoid confusion +-- between Gloss and Yampa. +type InputEvent = G.Event + +data Tile = Number Int | Empty deriving (Eq, Show) + +type Row = Int +type Column = Int + +newtype Board = Board [[Tile]] deriving (Eq, Show) + +data GameStatus = InProgress + | GameOver + deriving (Eq, Show) + +data GameState = GameState { board :: Board + , score :: Int + , status :: GameStatus + , gen :: StdGen + } deriving (Show) + +data Direction = Up | Down | Left | Right | None deriving (Eq, Show) + +type GameInput = Event Direction diff --git a/yampa2048.cabal b/yampa2048.cabal new file mode 100644 --- /dev/null +++ b/yampa2048.cabal @@ -0,0 +1,40 @@ +name: yampa2048 +version: 0.1.0.0 +synopsis: 2048 game clone using Yampa/Gloss +description: + + A simple game clone of a popular 2048 game using Yampa FRP + library and Gloss for graphics. + . + Use the arrow keys to slide the rows or columns of the board and try to + survive for as long as possible. When there is no more move possible you will + be presented with a game over message for 5 seconds and the game will be + restarted after that. + +license: MIT +license-file: LICENSE +author: Konstantin Saveljev +maintainer: Konstantin Saveljev +copyright: (C) 2015 Konstantin Saveljev, Josh Kirklin, Maia Werbos +category: Game +build-type: Simple +extra-source-files: README.md +cabal-version: >= 1.18 +homepage: https://github.com/ksaveljev/yampa-2048 +bug-reports: https://github.com/ksaveljev/yampa-2048/issues + +executable yampa2048 + main-is: Main.hs + other-modules: Game + , GameLogic + , GameModel + , Rendering + , Types + , Graphics.Gloss.Interface.FRP.Yampa + build-depends: base >=4.7 && <4.8 + , random + , gloss == 1.9.* + , Yampa == 0.9.* + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -O2