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,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