diff --git a/app/Assets.hs b/app/Assets.hs new file mode 100644 index 0000000..95380b4 --- /dev/null +++ b/app/Assets.hs @@ -0,0 +1,18 @@ +module Assets where + +import SDL +import qualified SDL.Image as IMG +import qualified SDL.Font as FONT + +type Assets = (Texture, FONT.Font) + +loadAssets :: Renderer -> IO Assets +loadAssets renderer = do + texture <- IMG.loadTexture renderer "assets/spritesheet.png" + font <- FONT.load "assets/font.ttf" 24 + pure (texture, font) + +freeAssets :: Assets -> IO () +freeAssets (texture, font) = do + destroyTexture texture + FONT.free font diff --git a/app/Graphics.hs b/app/Graphics.hs index 2e797de..1b7b427 100644 --- a/app/Graphics.hs +++ b/app/Graphics.hs @@ -1,19 +1,32 @@ module Graphics ( - renderFrame + renderFrame, + tileSize ) where import SDL -import SnakeLib +import qualified SDL.Font as FONT import Foreign.C (CInt) import Data.Array (assocs) import Control.Monad (void) -renderFrame :: Renderer -> Texture -> Game -> IO () -renderFrame renderer texture game = do +import Snake + +import Assets +import qualified Data.Text as Text + +spriteSize :: CInt +spriteSize = 16 + +tileSize :: CInt +tileSize = 64 + +renderFrame :: Renderer -> Assets -> Game -> IO () +renderFrame renderer (texture, font) game = do rendererDrawColor renderer $= V4 32 32 32 255 clear renderer rendererDrawColor renderer $= V4 255 255 255 255 renderGame renderer texture game + renderScore renderer font game present renderer renderGame :: Renderer -> Texture -> Game -> IO () @@ -26,6 +39,19 @@ renderTile renderer texture (pos, tile) = case tile of Apple -> renderSpriteAt renderer texture APPLE pos SnakeSegment orientation -> renderSpriteAt renderer texture (snakeSprite orientation) pos +renderScore :: Renderer -> FONT.Font -> Game -> IO () +renderScore renderer font game = do + let score = snakeSegmentCount game + surface <- FONT.blended font (V4 255 255 255 255) $ Text.pack ("Score: " ++ show score) + texture <- createTextureFromSurface renderer surface + freeSurface surface + + width <- textureWidth <$> queryTexture texture + height <- textureHeight <$> queryTexture texture + copy renderer texture Nothing (Just (Rectangle (P (V2 20 20)) (V2 width height))) + + destroyTexture texture + snakeSprite :: SnakeSegmentOrientation -> Sprite snakeSprite HEAD_DOWN = SNAKE_HEAD_DOWN snakeSprite HEAD_LEFT = SNAKE_HEAD_LEFT @@ -45,11 +71,11 @@ snakeSprite TAIL_LEFT = SNAKE_TAIL_LEFT renderSpriteAt :: Renderer -> Texture -> Sprite -> (Int, Int) -> IO () renderSpriteAt renderer texture sprite (x, y) = do let srcRect = getSpriteSheetLocation $ getSpriteIndex sprite - let dstRect = Rectangle (P (V2 (64 * (fromIntegral x)) (64 * (fromIntegral y)))) (V2 64 64) + let dstRect = Rectangle (P (V2 (tileSize * (fromIntegral x)) (tileSize * (fromIntegral y)))) (V2 tileSize tileSize) copy renderer texture (Just srcRect) (Just dstRect) getSpriteSheetLocation :: (Int, Int) -> Rectangle CInt -getSpriteSheetLocation (y, x) = Rectangle (P (V2 (16 * (fromIntegral x)) (16 * (fromIntegral y)))) (V2 16 16) +getSpriteSheetLocation (y, x) = Rectangle (P (V2 (spriteSize * (fromIntegral x)) (spriteSize * (fromIntegral y)))) (V2 spriteSize spriteSize) getSpriteIndex :: Sprite -> (Int, Int) getSpriteIndex SNAKE_HEAD_DOWN = (0, 0) diff --git a/app/Main.hs b/app/Main.hs index c950c07..e559480 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,25 +1,28 @@ module Main where import SDL -import qualified SDL.Image as IMG +import qualified SDL.Font as FONT import qualified Data.Text as Text import Control.Monad (unless) -import Graphics -import SnakeLib import SDL.Raw (getTicks) import Data.Word (Word32) +import Foreign.C (CInt) + +import Snake + +import Assets +import Graphics main :: IO () main = do initializeAll - window <- createWindow (Text.pack "Hello, World") defaultWindow + FONT.initialize + window <- createWindow (Text.pack "Haskell Snake") defaultWindow {windowInitialSize = snakeWindowSize} renderer <- createRenderer window (-1) defaultRenderer - texture <- IMG.loadTexture renderer "assets/spritesheet.png" - - appLoop renderer texture (initialState (10, 10) (2, 2)) - - destroyTexture texture + assets <- loadAssets renderer + appLoop renderer assets (initialState boardSize (2, 2)) + freeAssets assets destroyRenderer renderer destroyWindow window @@ -29,32 +32,47 @@ targetFps = 5 targetFrameMs :: Word32 targetFrameMs = 1000 `div` targetFps -appLoop :: Renderer -> Texture -> Game -> IO () -appLoop renderer texture game = do +boardSize :: (Int, Int) +boardSize = (12, 8) + +boardWindowSize :: (Int, Int) -> V2 CInt +boardWindowSize (w, h) = V2 (fromIntegral w * tileSize) (fromIntegral h * tileSize) + +snakeWindowSize :: V2 CInt +snakeWindowSize = boardWindowSize boardSize + +appLoop :: Renderer -> Assets -> Game -> IO () +appLoop renderer assets game = do frameStart <- getTicks events <- pollEvents let eventIsExitPress event = case eventPayload event of - KeyboardEvent keyboardEvent -> - keyboardEventKeyMotion keyboardEvent == Pressed && - keysymKeycode (keyboardEventKeysym keyboardEvent) == KeycodeQ - WindowClosedEvent _ -> True - _ -> False + KeyboardEvent keyboardEvent -> + keyboardEventKeyMotion keyboardEvent == Pressed && + keysymKeycode (keyboardEventKeysym keyboardEvent) == KeycodeQ + WindowClosedEvent _ -> True + _ -> False exitPressed = any eventIsExitPress events - let eventDirectionPressed event = case eventPayload event of + let eventIsRestartPress event = case eventPayload event of + KeyboardEvent keyboardEvent -> + keyboardEventKeyMotion keyboardEvent == Pressed && + keysymKeycode (keyboardEventKeysym keyboardEvent) == KeycodeR + _ -> False + restartPresssed = any eventIsRestartPress events + let eventDirectionPress event = case eventPayload event of KeyboardEvent keyboardEvent -> if keyboardEventKeyMotion keyboardEvent == Pressed then getInputByKeycode $ keysymKeycode (keyboardEventKeysym keyboardEvent) else NothingPressed _ -> NothingPressed - input = foldMap eventDirectionPressed events - frameEnd <- getTicks - let elapsed = frameEnd - frameStart - (_, updatedGame) <- runTick game input - renderFrame renderer texture updatedGame + input = foldMap eventDirectionPress events + (_, updatedGame) <- if restartPresssed then pure (IntoEmpty, initialState (10, 8) (2, 2)) else runTick game input + renderFrame renderer assets updatedGame unless exitPressed $ do + frameEnd <- getTicks + let elapsed = frameEnd - frameStart delay (targetFrameMs - elapsed) - appLoop renderer texture updatedGame + appLoop renderer assets updatedGame getInputByKeycode :: Keycode -> MovementInput getInputByKeycode KeycodeW = UpPressed diff --git a/assets/font.ttf b/assets/font.ttf new file mode 100644 index 0000000..7340a40 Binary files /dev/null and b/assets/font.ttf differ diff --git a/snake-hs.cabal b/snake-hs.cabal index ff0f3fc..0b4a44d 100644 --- a/snake-hs.cabal +++ b/snake-hs.cabal @@ -58,7 +58,9 @@ library import: warnings -- Modules exported by the library. - exposed-modules: SnakeLib + exposed-modules: + Snake + Tile -- Modules included in this library but not exported. -- other-modules: @@ -88,6 +90,7 @@ executable snake-hs -- Modules included in this executable, other than Main. other-modules: + Assets Graphics -- LANGUAGE extensions used by modules in this package. @@ -100,7 +103,8 @@ executable snake-hs text, array, sdl2, - sdl2-image + sdl2-image, + sdl2-ttf -- Directories containing source files. hs-source-dirs: app diff --git a/src/SnakeLib.hs b/src/Snake.hs similarity index 66% rename from src/SnakeLib.hs rename to src/Snake.hs index c232eee..bde815f 100644 --- a/src/SnakeLib.hs +++ b/src/Snake.hs @@ -1,6 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} -module SnakeLib ( - MovementInput (..), +module Snake ( Tile (..), Pos, Board, @@ -10,18 +9,22 @@ module SnakeLib ( runTick, + MovementInput (..), + MovementResult (..), + SnakeSegmentOrientation (..), Direction (..), growHead, - shrinkTail + shrinkTail, + + snakeSegmentCount ) where import Data.Array import Control.Monad.State -import Control.Monad (when, unless) +import Control.Monad (when) import System.Random (randomRIO) - -data Tile = SnakeSegment SnakeSegmentOrientation | Apple | Empty deriving (Eq, Show) +import Tile type Pos = (Int, Int) @@ -29,6 +32,18 @@ type Board = Array Pos Tile data Game = Game {gameBoard :: Board, gameBoardSize :: (Int, Int), snakeHead :: Pos, snakeTail :: Pos} +data MovementInput = UpPressed | RightPressed | DownPressed | LeftPressed | NothingPressed deriving (Eq, Show) + +instance Semigroup MovementInput where + (<>) l NothingPressed = l + NothingPressed <> r = r + l <> _ = l + +instance Monoid MovementInput where + mempty = NothingPressed + +data MovementResult = IntoApple | IntoSnake | IntoEmpty deriving (Eq, Show) + emptyBoard :: (Int, Int) -> Array (Int, Int) Tile emptyBoard (w, h) = array ((0, 0), (w-1, h-1)) [((i, j), Empty) | i <- [0..w-1], j <- [0..h-1]] @@ -51,7 +66,7 @@ gameTick input = do advanceSnake :: MonadState Game m => MovementInput -> m MovementResult advanceSnake input = do - idleDirection <- headDirection + idleDirection <- getHeadDirection let inputDirection = case input of UpPressed -> UP RightPressed -> RIGHT @@ -67,8 +82,8 @@ advanceSnake input = do Empty -> moveHead direction >> pure IntoEmpty SnakeSegment _ -> pure IntoSnake -headDirection :: MonadState Game m => m Direction -headDirection = gets f +getHeadDirection :: MonadState Game m => m Direction +getHeadDirection = gets f where f :: Game -> Direction f game = case tileAt (gameBoard game) (snakeHead game) of @@ -90,27 +105,6 @@ moveHead direction = do let modifiedBoard = board // [(pos, SnakeSegment $ growHead orientation direction), (destination, SnakeSegment $ getNewHead direction)] modify (\s -> s {gameBoard=modifiedBoard, snakeHead=destination}) -growHead :: SnakeSegmentOrientation -> Direction -> SnakeSegmentOrientation -growHead HEAD_UP UP = VERTICAL -growHead HEAD_UP LEFT = TURN_DOWN_LEFT -growHead HEAD_UP RIGHT = TURN_DOWN_RIGHT -growHead HEAD_RIGHT RIGHT = HORIZONTAL -growHead HEAD_RIGHT UP = TURN_UP_LEFT -growHead HEAD_RIGHT DOWN = TURN_DOWN_LEFT -growHead HEAD_DOWN DOWN = VERTICAL -growHead HEAD_DOWN RIGHT = TURN_UP_RIGHT -growHead HEAD_DOWN LEFT = TURN_UP_LEFT -growHead HEAD_LEFT LEFT = HORIZONTAL -growHead HEAD_LEFT DOWN = TURN_DOWN_RIGHT -growHead HEAD_LEFT UP = TURN_UP_RIGHT -growHead _ _ = error "Invalid growHead arguments" - -getNewHead :: Direction -> SnakeSegmentOrientation -getNewHead UP = HEAD_UP -getNewHead RIGHT = HEAD_RIGHT -getNewHead DOWN = HEAD_DOWN -getNewHead LEFT = HEAD_LEFT - shrinkSnake :: MonadState Game m => m () shrinkSnake = do pos <- gets snakeTail @@ -130,25 +124,6 @@ shrinkSnake = do let modifiedBoard = board // [(pos, Empty), (destination, SnakeSegment $ shrinkTail orientation direction)] modify (\s -> s {gameBoard=modifiedBoard, snakeTail=destination}) -shrinkTail :: SnakeSegmentOrientation -> Direction -> SnakeSegmentOrientation -shrinkTail HEAD_UP UP = TAIL_UP -shrinkTail HEAD_RIGHT RIGHT = TAIL_RIGHT -shrinkTail HEAD_DOWN DOWN = TAIL_DOWN -shrinkTail HEAD_LEFT LEFT = TAIL_LEFT -shrinkTail TURN_UP_RIGHT LEFT = TAIL_UP -shrinkTail TURN_UP_RIGHT DOWN = TAIL_RIGHT -shrinkTail TURN_DOWN_RIGHT LEFT = TAIL_DOWN -shrinkTail TURN_DOWN_RIGHT UP = TAIL_RIGHT -shrinkTail TURN_DOWN_LEFT RIGHT = TAIL_DOWN -shrinkTail TURN_DOWN_LEFT UP = TAIL_LEFT -shrinkTail TURN_UP_LEFT RIGHT = TAIL_UP -shrinkTail TURN_UP_LEFT DOWN = TAIL_LEFT -shrinkTail HORIZONTAL RIGHT = TAIL_RIGHT -shrinkTail HORIZONTAL LEFT = TAIL_LEFT -shrinkTail VERTICAL UP = TAIL_UP -shrinkTail VERTICAL DOWN = TAIL_DOWN -shrinkTail o d = error ("Invalid shrinkTail arguments: " ++ show o ++ " " ++ show d) - spawnApple :: (MonadState Game m, MonadIO m) => m () spawnApple = do (w, h) <- gets gameBoardSize @@ -158,6 +133,12 @@ spawnApple = do Empty -> modify (\s -> s {gameBoard = gameBoard s // [(pos, Apple)]}) _ -> spawnApple +snakeSegmentCount :: Game -> Int +snakeSegmentCount = length . filter isSnakeSegment . elems . gameBoard + +isSnakeSegment :: Tile -> Bool +isSnakeSegment (SnakeSegment _) = True +isSnakeSegment _ = False tileAt :: Board -> Pos -> Tile tileAt board (x, y) = (board ! (x, y)) @@ -174,36 +155,5 @@ shiftPos (x, y) direction = do size <- gets gameBoardSize pure $ wrapPos size (x + dx, y + dy) -data MovementInput = UpPressed | RightPressed | DownPressed | LeftPressed | NothingPressed deriving (Eq, Show) -instance Semigroup MovementInput where - (<>) l NothingPressed = l - NothingPressed <> r = r - l <> _ = l -instance Monoid MovementInput where - mempty = NothingPressed - -data MovementResult = IntoApple | IntoSnake | IntoEmpty deriving (Eq, Show) - -data SnakeSegmentOrientation = - HEAD_DOWN | HEAD_LEFT | HEAD_UP | HEAD_RIGHT | - TURN_UP_RIGHT | TURN_DOWN_RIGHT | TURN_DOWN_LEFT | TURN_UP_LEFT | - VERTICAL | HORIZONTAL | - TAIL_UP | TAIL_RIGHT | TAIL_DOWN | TAIL_LEFT - deriving (Eq, Show) - -data Direction = DOWN | LEFT | UP | RIGHT deriving (Eq, Show) - -areOpposite :: Direction -> Direction -> Bool -areOpposite UP DOWN = True -areOpposite DOWN UP = True -areOpposite LEFT RIGHT = True -areOpposite RIGHT LEFT = True -areOpposite _ _ = False - -getDelta :: Direction -> (Int, Int) -getDelta UP = (0, -1) -getDelta RIGHT = (1, 0) -getDelta DOWN = (0, 1) -getDelta LEFT = (-1, 0) diff --git a/src/Tile.hs b/src/Tile.hs new file mode 100644 index 0000000..730becb --- /dev/null +++ b/src/Tile.hs @@ -0,0 +1,74 @@ +module Tile ( + Tile (..), + SnakeSegmentOrientation (..), + Direction (..), + areOpposite, + growHead, + getNewHead, + shrinkTail, + getDelta +) where + +data Tile = SnakeSegment SnakeSegmentOrientation | Apple | Empty deriving (Eq, Show) + +data SnakeSegmentOrientation = + HEAD_DOWN | HEAD_LEFT | HEAD_UP | HEAD_RIGHT | + TURN_UP_RIGHT | TURN_DOWN_RIGHT | TURN_DOWN_LEFT | TURN_UP_LEFT | + VERTICAL | HORIZONTAL | + TAIL_UP | TAIL_RIGHT | TAIL_DOWN | TAIL_LEFT + deriving (Eq, Show) + +data Direction = DOWN | LEFT | UP | RIGHT deriving (Eq, Show) + +areOpposite :: Direction -> Direction -> Bool +areOpposite UP DOWN = True +areOpposite DOWN UP = True +areOpposite LEFT RIGHT = True +areOpposite RIGHT LEFT = True +areOpposite _ _ = False + +growHead :: SnakeSegmentOrientation -> Direction -> SnakeSegmentOrientation +growHead HEAD_UP UP = VERTICAL +growHead HEAD_UP LEFT = TURN_DOWN_LEFT +growHead HEAD_UP RIGHT = TURN_DOWN_RIGHT +growHead HEAD_RIGHT RIGHT = HORIZONTAL +growHead HEAD_RIGHT UP = TURN_UP_LEFT +growHead HEAD_RIGHT DOWN = TURN_DOWN_LEFT +growHead HEAD_DOWN DOWN = VERTICAL +growHead HEAD_DOWN RIGHT = TURN_UP_RIGHT +growHead HEAD_DOWN LEFT = TURN_UP_LEFT +growHead HEAD_LEFT LEFT = HORIZONTAL +growHead HEAD_LEFT DOWN = TURN_DOWN_RIGHT +growHead HEAD_LEFT UP = TURN_UP_RIGHT +growHead _ _ = error "Invalid growHead arguments" + +getNewHead :: Direction -> SnakeSegmentOrientation +getNewHead UP = HEAD_UP +getNewHead RIGHT = HEAD_RIGHT +getNewHead DOWN = HEAD_DOWN +getNewHead LEFT = HEAD_LEFT + +shrinkTail :: SnakeSegmentOrientation -> Direction -> SnakeSegmentOrientation +shrinkTail HEAD_UP UP = TAIL_UP +shrinkTail HEAD_RIGHT RIGHT = TAIL_RIGHT +shrinkTail HEAD_DOWN DOWN = TAIL_DOWN +shrinkTail HEAD_LEFT LEFT = TAIL_LEFT +shrinkTail TURN_UP_RIGHT LEFT = TAIL_UP +shrinkTail TURN_UP_RIGHT DOWN = TAIL_RIGHT +shrinkTail TURN_DOWN_RIGHT LEFT = TAIL_DOWN +shrinkTail TURN_DOWN_RIGHT UP = TAIL_RIGHT +shrinkTail TURN_DOWN_LEFT RIGHT = TAIL_DOWN +shrinkTail TURN_DOWN_LEFT UP = TAIL_LEFT +shrinkTail TURN_UP_LEFT RIGHT = TAIL_UP +shrinkTail TURN_UP_LEFT DOWN = TAIL_LEFT +shrinkTail HORIZONTAL RIGHT = TAIL_RIGHT +shrinkTail HORIZONTAL LEFT = TAIL_LEFT +shrinkTail VERTICAL UP = TAIL_UP +shrinkTail VERTICAL DOWN = TAIL_DOWN +shrinkTail o d = error ("Invalid shrinkTail arguments: " ++ show o ++ " " ++ show d) + +getDelta :: Direction -> (Int, Int) +getDelta UP = (0, -1) +getDelta RIGHT = (1, 0) +getDelta DOWN = (0, 1) +getDelta LEFT = (-1, 0) diff --git a/test/Main.hs b/test/Main.hs index b99cff1..46f5ab1 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,7 +1,7 @@ module Main (main) where -import Data.Array (elems, (!)) -import SnakeLib +import Data.Array ((!)) +import Snake import Test.Tasty (TestTree, defaultMain, testGroup) import Test.Tasty.HUnit (assertEqual, testCase) @@ -125,9 +125,3 @@ runTickTests = assertEqual "tail advanced" (1, 0) (snakeTail step4) ] -snakeSegmentCount :: Game -> Int -snakeSegmentCount = length . filter isSnakeSegment . elems . gameBoard - -isSnakeSegment :: Tile -> Bool -isSnakeSegment (SnakeSegment _) = True -isSnakeSegment _ = False