Score rendering

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

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)

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,8 +32,17 @@ 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
@@ -40,21 +52,27 @@ appLoop renderer texture game = do
             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

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

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)

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)

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