snake-hs/app/Graphics.hs

module Graphics (
    renderFrame,
    tileSize
) where

import SDL
import qualified SDL.Font as FONT
import Foreign.C (CInt)
import Data.Array (assocs)
import Control.Monad (void, when)

import Snake

import Assets
import qualified Data.Text as Text
import Data.Word (Word8)

spriteSize :: CInt
spriteSize = 16

tileSize :: CInt
tileSize = 64

renderFrame :: Renderer -> Assets -> (Game, Bool) -> IO ()
renderFrame renderer (texture, font) (game, isEnd) = do
    rendererDrawColor renderer $= V4 0 0 0 255
    clear renderer
    renderBG renderer (gameBoardSize game)
    rendererDrawColor renderer $= V4 255 255 255 255
    renderGame renderer texture game
    renderScore renderer font game
    when isEnd $ renderDefeat renderer font
    present renderer

renderBG :: Renderer -> (Int, Int) -> IO ()
renderBG renderer (w, h) = do
    void $ traverse (renderBGTile renderer) [(x, y) | x <- [0..w-1], y <- [0..h-1]]

tileColors :: (V4 Word8, V4 Word8)
tileColors = (V4 32 32 32 255, V4 64 64 64 255)

renderBGTile :: Renderer -> (Int, Int) -> IO ()
renderBGTile renderer (x, y) = do
    rendererDrawColor renderer $= ((if even (x + y) then fst else snd) tileColors)
    fillRect renderer (Just $ Rectangle (P $ V2 (fromIntegral x * tileSize) (fromIntegral y * tileSize)) (V2 tileSize tileSize))

renderGame :: Renderer -> Texture -> Game -> IO ()
renderGame renderer texture state = do
    void $ traverse (renderTile renderer texture) (assocs $ gameBoard state)

renderTile :: Renderer -> Texture -> (Pos, Tile) -> IO ()
renderTile renderer texture (pos, tile) = case tile of
    Empty -> return ()
    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

renderDefeat :: Renderer -> FONT.Font -> IO ()
renderDefeat renderer font = do
    surface <- FONT.blended font (V4 200 50 50 255) $ Text.pack ("You died! Press R to restart.")
    texture <- createTextureFromSurface renderer surface
    freeSurface surface

    width <- textureWidth <$> queryTexture texture
    height <- textureHeight <$> queryTexture texture
    copy renderer texture Nothing (Just (Rectangle (P (V2 20 60)) (V2 width height)))

    destroyTexture texture

snakeSprite :: SnakeSegmentOrientation -> Sprite
snakeSprite HEAD_DOWN = SNAKE_HEAD_DOWN
snakeSprite HEAD_LEFT = SNAKE_HEAD_LEFT
snakeSprite HEAD_UP = SNAKE_HEAD_UP
snakeSprite HEAD_RIGHT = SNAKE_HEAD_RIGHT
snakeSprite VERTICAL = SNAKE_VERTICAL
snakeSprite HORIZONTAL = SNAKE_HORIZONTAL
snakeSprite TURN_UP_RIGHT = SNAKE_TURN_UP_RIGHT
snakeSprite TURN_DOWN_RIGHT = SNAKE_TURN_DOWN_RIGHT
snakeSprite TURN_DOWN_LEFT = SNAKE_TURN_DOWN_LEFT
snakeSprite TURN_UP_LEFT = SNAKE_TURN_UP_LEFT
snakeSprite TAIL_UP = SNAKE_TAIL_UP
snakeSprite TAIL_RIGHT = SNAKE_TAIL_RIGHT
snakeSprite TAIL_DOWN = SNAKE_TAIL_DOWN
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 (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 (spriteSize * (fromIntegral x)) (spriteSize * (fromIntegral y)))) (V2 spriteSize spriteSize)

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