Sprite rendering

app/Graphics.hs

@@ -0,0 +1,80 @@
+module Graphics (
+    renderFrame
+) where
+
+import SDL
+import SnakeLib
+import Foreign.C (CInt)
+import Data.Array (indices)
+import Control.Monad (void)
+
+renderFrame :: Renderer -> Texture -> IO ()
+renderFrame renderer texture = do
+    rendererDrawColor renderer $= V4 32 32 32 255
+    clear renderer
+    rendererDrawColor renderer $= V4 255 255 255 255
+    renderState renderer texture $ initialState (20, 20) (2, 2)
+    present renderer
+
+renderState :: Renderer -> Texture -> GameState -> IO ()
+renderState renderer texture state = do
+    void $ traverse (renderTile renderer texture state) (indices $ gameBoard state)
+
+renderTile :: Renderer -> Texture -> GameState -> Pos -> IO ()
+renderTile renderer texture state pos = case tileAt (gameBoard state) pos of
+    Empty -> return ()
+    Apple -> renderSpriteAt renderer texture APPLE pos
+    Snake -> 
+        let size = gameBoardSize state
+        in renderSpriteAt renderer texture (snakeSprite (neighborTiles size (gameBoard state) pos) (pos == snakeHead state))pos
+
+snakeSprite :: (Tile, Tile, Tile, Tile) -> Bool -> Sprite
+snakeSprite (Snake, _, _, _) True = SNAKE_HEAD_DOWN
+snakeSprite (_, Snake, _, _) True = SNAKE_HEAD_LEFT
+snakeSprite (_, _, Snake, _) True = SNAKE_HEAD_UP
+snakeSprite (_, _, _, Snake) True = SNAKE_HEAD_RIGHT
+snakeSprite (Snake, _, Snake, _) _ = SNAKE_VERTICAL
+snakeSprite (_, Snake, _, Snake) _ = SNAKE_HORIZONTAL
+snakeSprite (Snake, Snake, _, _) _ = SNAKE_TURN_UP_RIGHT
+snakeSprite (_, Snake, Snake, _) _ = SNAKE_TURN_DOWN_RIGHT
+snakeSprite (_, _, Snake, Snake) _ = SNAKE_TURN_DOWN_LEFT
+snakeSprite (Snake, _, _, Snake) _ = SNAKE_TURN_UP_LEFT
+snakeSprite (Snake, _, _, _) _ = SNAKE_TAIL_UP
+snakeSprite (_, Snake, _, _) _ = SNAKE_TAIL_RIGHT
+snakeSprite (_, _, Snake, _) _ = SNAKE_TAIL_DOWN
+snakeSprite (_, _, _, Snake) _ = SNAKE_TAIL_LEFT
+snakeSprite _ _ = APPLE
+
+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)
+    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)
+
+getSpriteIndex :: Sprite -> (Int, Int)
+getSpriteIndex SNAKE_HEAD_DOWN = (0, 0)
+getSpriteIndex SNAKE_HEAD_LEFT = (0, 1)
+getSpriteIndex SNAKE_HEAD_UP = (0, 2)
+getSpriteIndex SNAKE_HEAD_RIGHT = (0, 3)
+getSpriteIndex SNAKE_TURN_UP_RIGHT = (1, 0)
+getSpriteIndex SNAKE_TURN_DOWN_RIGHT = (1, 1)
+getSpriteIndex SNAKE_TURN_DOWN_LEFT = (1, 2)
+getSpriteIndex SNAKE_TURN_UP_LEFT = (1, 3)
+getSpriteIndex SNAKE_VERTICAL = (2, 0)
+getSpriteIndex SNAKE_HORIZONTAL = (2, 1)
+getSpriteIndex SNAKE_TAIL_UP = (3, 0)
+getSpriteIndex SNAKE_TAIL_RIGHT = (3, 1)
+getSpriteIndex SNAKE_TAIL_DOWN = (3, 2)
+getSpriteIndex SNAKE_TAIL_LEFT = (3, 3)
+getSpriteIndex APPLE = (2, 2)
+
+data Sprite = 
+    SNAKE_HEAD_DOWN | SNAKE_HEAD_LEFT | SNAKE_HEAD_UP | SNAKE_HEAD_RIGHT |
+    SNAKE_TURN_UP_RIGHT | SNAKE_TURN_DOWN_RIGHT | SNAKE_TURN_DOWN_LEFT | SNAKE_TURN_UP_LEFT |
+    SNAKE_VERTICAL | SNAKE_HORIZONTAL |
+    SNAKE_TAIL_UP | SNAKE_TAIL_RIGHT | SNAKE_TAIL_DOWN | SNAKE_TAIL_LEFT |
+    APPLE
+

app/Main.hs

@@ -1,8 +1,48 @@
 module Main where
 
-import qualified MyLib (someFunc)
+import SDL
+import qualified SDL.Image as IMG
+import qualified Data.Text as Text
+import Control.Monad (unless)
+import Graphics
+import SnakeLib
+import SDL.Raw (getTicks)
+import Data.Word (Word32)
 
 main :: IO ()
 main = do
-  putStrLn "Hello, Haskell!"
+    initializeAll
-  MyLib.someFunc
+    window <- createWindow (Text.pack "Hello, World") defaultWindow
+    renderer <- createRenderer window (-1) defaultRenderer
+    
+    texture <- IMG.loadTexture renderer "assets/spritesheet.png"
+
+    appLoop renderer texture
+
+    destroyTexture texture
+    destroyRenderer renderer
+    destroyWindow window
+
+targetFps :: Word32
+targetFps = 60
+
+targetFrameMs :: Word32
+targetFrameMs = 1000 `div` targetFps
+
+appLoop :: Renderer -> Texture -> IO ()
+appLoop renderer texture = do
+    frameStart <- getTicks
+    events <- pollEvents
+    let eventIsExitPress event = case eventPayload event of
+          KeyboardEvent keyboardEvent ->
+            keyboardEventKeyMotion keyboardEvent == Pressed &&
+            keysymKeycode (keyboardEventKeysym keyboardEvent) == KeycodeQ
+          WindowClosedEvent _ -> True
+          _ -> False
+        exitPressed = any eventIsExitPress events
+    renderFrame renderer texture
+    frameEnd <- getTicks
+    let elapsed = frameEnd - frameStart
+    delay (targetFrameMs - elapsed)
+    unless exitPressed (appLoop renderer texture)
+

snake-hs.cabal

@@ -58,7 +58,7 @@ library
     import:           warnings
 
     -- Modules exported by the library.
-    exposed-modules:  MyLib
+    exposed-modules:  SnakeLib
 
     -- Modules included in this library but not exported.
     -- other-modules:
@@ -67,7 +67,9 @@ library
     -- other-extensions:
 
     -- Other library packages from which modules are imported.
-    build-depends:    base ^>=4.20.2.0
+    build-depends:
+        base ^>=4.20.2.0,
+        array
 
     -- Directories containing source files.
     hs-source-dirs:   src
@@ -83,7 +85,8 @@ executable snake-hs
     main-is:          Main.hs
 
     -- Modules included in this executable, other than Main.
-    -- other-modules:
+    other-modules:
+        Graphics
 
     -- LANGUAGE extensions used by modules in this package.
     -- other-extensions:
@@ -91,7 +94,11 @@ executable snake-hs
     -- Other library packages from which modules are imported.
     build-depends:
         base ^>=4.20.2.0,
-        snake-hs
+        snake-hs,
+        text,
+        array,
+        sdl2,
+        sdl2-image
 
     -- Directories containing source files.
     hs-source-dirs:   app

src/MyLib.hs

@@ -1,4 +0,0 @@
-module MyLib (someFunc) where
-
-someFunc :: IO ()
-someFunc = putStrLn "someFunc"

src/SnakeLib.hs

@@ -0,0 +1,47 @@
+module SnakeLib (
+    MovementInput (..),
+    Tile (..),
+    Pos,
+    Board,
+    tileAt,
+    wrapPos,
+    neighborTiles,
+
+    GameState (..),
+    initialState
+) where
+
+import Data.Array
+
+data MovementInput = UpPressed | RightPressed | DownPressed | LeftPressed | NothingPressed
+
+data Tile = Snake | Apple | Empty
+
+type Pos = (Int, Int)
+type Board = Array Pos Tile
+
+tileAt :: Board -> Pos -> Tile
+tileAt board (x, y) = (board ! (x, y))
+
+wrapPos :: (Int, Int) -> Pos -> Pos
+wrapPos (w, h) (x, y) =
+  (x `mod` w, y `mod` h)
+
+neighborTiles :: (Int, Int) -> Board -> Pos -> (Tile, Tile, Tile, Tile)
+neighborTiles size board (x, y) =
+  ( tileAt board (wrapPos size (x, y - 1))  -- up
+  , tileAt board (wrapPos size (x + 1, y))  -- right
+  , tileAt board (wrapPos size (x, y + 1))  -- down
+  , tileAt board (wrapPos size (x - 1, y))  -- left
+  )
+
+data GameState = GameState {gameBoard :: Board, gameBoardSize :: (Int, Int), snakeHead :: Pos}
+
+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]]
+
+initialState :: (Int, Int) -> (Int, Int) -> GameState
+initialState size (x, y) = GameState {gameBoard=(emptyBoard size) // [((x-1, y), Snake), ((x, y), Snake)], gameBoardSize=size, snakeHead=(x, y)}
+
+gameTick :: GameState -> MovementInput -> GameState
+gameTick = undefined