yampa2048 (empty) → 0.1.0.0
raw patch · 11 files changed
+596/−0 lines, 11 filesdep +Yampadep +basedep +glosssetup-changed
Dependencies added: Yampa, base, gloss, random
Files
- LICENSE +24/−0
- README.md +38/−0
- Setup.hs +2/−0
- src/Game.hs +79/−0
- src/GameLogic.hs +117/−0
- src/GameModel.hs +64/−0
- src/Graphics/Gloss/Interface/FRP/Yampa.hs +36/−0
- src/Main.hs +42/−0
- src/Rendering.hs +115/−0
- src/Types.hs +39/−0
- yampa2048.cabal +40/−0
+ LICENSE view
@@ -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.+
+ README.md view
@@ -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.++++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
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Game.hs view
@@ -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
+ src/GameLogic.hs view
@@ -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+ ]
+ src/GameModel.hs view
@@ -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+ }
+ src/Graphics/Gloss/Interface/FRP/Yampa.hs view
@@ -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
+ src/Main.hs view
@@ -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)
+ src/Rendering.hs view
@@ -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
+ src/Types.hs view
@@ -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
+ yampa2048.cabal view
@@ -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 <konstantin.saveljev@gmail.com>+maintainer: Konstantin Saveljev <konstantin.saveljev@gmail.com>+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