Snake movement
This commit is contained in:
parent
a87fe00b52
commit
befd198c93
4 changed files with 218 additions and 52 deletions
|
|
@ -5,45 +5,42 @@ module Graphics (
|
|||
import SDL
|
||||
import SnakeLib
|
||||
import Foreign.C (CInt)
|
||||
import Data.Array (indices)
|
||||
import Data.Array (assocs)
|
||||
import Control.Monad (void)
|
||||
|
||||
renderFrame :: Renderer -> Texture -> IO ()
|
||||
renderFrame renderer texture = do
|
||||
renderFrame :: Renderer -> Texture -> Game -> IO ()
|
||||
renderFrame renderer texture game = 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)
|
||||
renderGame renderer texture game
|
||||
present renderer
|
||||
|
||||
renderState :: Renderer -> Texture -> GameState -> IO ()
|
||||
renderState renderer texture state = do
|
||||
void $ traverse (renderTile renderer texture state) (indices $ gameBoard state)
|
||||
renderGame :: Renderer -> Texture -> Game -> IO ()
|
||||
renderGame renderer texture state = do
|
||||
void $ traverse (renderTile renderer texture) (assocs $ gameBoard state)
|
||||
|
||||
renderTile :: Renderer -> Texture -> GameState -> Pos -> IO ()
|
||||
renderTile renderer texture state pos = case tileAt (gameBoard state) pos of
|
||||
renderTile :: Renderer -> Texture -> (Pos, Tile) -> IO ()
|
||||
renderTile renderer texture (pos, tile) = case tile 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
|
||||
Snake orientation -> renderSpriteAt renderer texture (snakeSprite orientation) 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
|
||||
snakeSprite :: SnakeOrientation -> 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
|
||||
|
|
|
|||
34
app/Main.hs
34
app/Main.hs
|
|
@ -17,20 +17,20 @@ main = do
|
|||
|
||||
texture <- IMG.loadTexture renderer "assets/spritesheet.png"
|
||||
|
||||
appLoop renderer texture
|
||||
appLoop renderer texture (initialState (20, 20) (2, 2))
|
||||
|
||||
destroyTexture texture
|
||||
destroyRenderer renderer
|
||||
destroyWindow window
|
||||
|
||||
targetFps :: Word32
|
||||
targetFps = 60
|
||||
targetFps = 2
|
||||
|
||||
targetFrameMs :: Word32
|
||||
targetFrameMs = 1000 `div` targetFps
|
||||
|
||||
appLoop :: Renderer -> Texture -> IO ()
|
||||
appLoop renderer texture = do
|
||||
appLoop :: Renderer -> Texture -> Game -> IO ()
|
||||
appLoop renderer texture game = do
|
||||
frameStart <- getTicks
|
||||
events <- pollEvents
|
||||
let eventIsExitPress event = case eventPayload event of
|
||||
|
|
@ -40,9 +40,29 @@ appLoop renderer texture = do
|
|||
WindowClosedEvent _ -> True
|
||||
_ -> False
|
||||
exitPressed = any eventIsExitPress events
|
||||
renderFrame renderer texture
|
||||
let eventDirectionPressed 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
|
||||
delay (targetFrameMs - elapsed)
|
||||
unless exitPressed (appLoop renderer texture)
|
||||
let updatedGame = execTick game input
|
||||
renderFrame renderer texture updatedGame
|
||||
|
||||
unless exitPressed $ do
|
||||
delay (targetFrameMs - elapsed)
|
||||
appLoop renderer texture updatedGame
|
||||
|
||||
getInputByKeycode :: Keycode -> MovementInput
|
||||
getInputByKeycode KeycodeW = UpPressed
|
||||
getInputByKeycode KeycodeUp = UpPressed
|
||||
getInputByKeycode KeycodeD = RightPressed
|
||||
getInputByKeycode KeycodeRight = RightPressed
|
||||
getInputByKeycode KeycodeS = DownPressed
|
||||
getInputByKeycode KeycodeDown = DownPressed
|
||||
getInputByKeycode KeycodeA = LeftPressed
|
||||
getInputByKeycode KeycodeLeft = LeftPressed
|
||||
getInputByKeycode _ = NothingPressed
|
||||
|
|
|
|||
|
|
@ -69,6 +69,7 @@ library
|
|||
-- Other library packages from which modules are imported.
|
||||
build-depends:
|
||||
base ^>=4.20.2.0,
|
||||
mtl,
|
||||
array
|
||||
|
||||
-- Directories containing source files.
|
||||
|
|
|
|||
182
src/SnakeLib.hs
182
src/SnakeLib.hs
|
|
@ -5,17 +5,30 @@ module SnakeLib (
|
|||
Board,
|
||||
tileAt,
|
||||
wrapPos,
|
||||
neighborTiles,
|
||||
|
||||
GameState (..),
|
||||
initialState
|
||||
Game (..),
|
||||
initialState,
|
||||
|
||||
execTick,
|
||||
|
||||
SnakeOrientation (..)
|
||||
) where
|
||||
|
||||
import Data.Array
|
||||
import Control.Monad.State
|
||||
import Control.Monad (when)
|
||||
|
||||
data MovementInput = UpPressed | RightPressed | DownPressed | LeftPressed | NothingPressed
|
||||
data MovementInput = UpPressed | RightPressed | DownPressed | LeftPressed | NothingPressed deriving (Eq, Show)
|
||||
|
||||
data Tile = Snake | Apple | Empty
|
||||
instance Semigroup MovementInput where
|
||||
(<>) l NothingPressed = l
|
||||
NothingPressed <> r = r
|
||||
l <> _ = l
|
||||
|
||||
instance Monoid MovementInput where
|
||||
mempty = NothingPressed
|
||||
|
||||
data Tile = Snake SnakeOrientation | Apple | Empty
|
||||
|
||||
type Pos = (Int, Int)
|
||||
type Board = Array Pos Tile
|
||||
|
|
@ -27,21 +40,156 @@ 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 Game = Game {gameBoard :: Board, gameBoardSize :: (Int, Int), snakeHead :: Pos, snakeTail :: Pos}
|
||||
|
||||
data GameState = GameState {gameBoard :: Board, gameBoardSize :: (Int, Int), snakeHead :: Pos}
|
||||
type GameState = State Game
|
||||
|
||||
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)}
|
||||
initialState :: (Int, Int) -> (Int, Int) -> Game
|
||||
initialState size (x, y) = Game
|
||||
{ gameBoard=(emptyBoard size) // [((x-1, y), Snake TAIL_RIGHT), ((x, y), Snake HEAD_RIGHT)]
|
||||
, gameBoardSize=size
|
||||
, snakeHead=(x, y)
|
||||
, snakeTail=(x-1, y)}
|
||||
|
||||
gameTick :: GameState -> MovementInput -> GameState
|
||||
gameTick = undefined
|
||||
execTick :: Game -> MovementInput -> Game
|
||||
execTick game input = execState (gameTick input) game
|
||||
|
||||
gameTick :: MovementInput -> GameState MovementResult
|
||||
gameTick input = do
|
||||
movementResult <- advanceSnake input
|
||||
when (movementResult == IntoEmpty) shrinkSnake
|
||||
pure movementResult
|
||||
|
||||
advanceSnake :: MovementInput -> GameState MovementResult
|
||||
advanceSnake input = do
|
||||
idleDirection <- headDirection
|
||||
let inputDirection = case input of
|
||||
UpPressed -> UP
|
||||
RightPressed -> RIGHT
|
||||
DownPressed -> DOWN
|
||||
LeftPressed -> LEFT
|
||||
NothingPressed -> idleDirection
|
||||
let direction = if areOpposite idleDirection inputDirection then idleDirection else inputDirection
|
||||
pos <- gets snakeHead
|
||||
destination <- shiftPos pos direction
|
||||
destinationTile <- gets ((`tileAt` destination) . gameBoard)
|
||||
case destinationTile of
|
||||
Apple -> moveHead direction >> pure IntoApple
|
||||
Empty -> moveHead direction >> pure IntoEmpty
|
||||
Snake _ -> pure IntoSnake
|
||||
|
||||
headDirection :: GameState Direction
|
||||
headDirection = gets f
|
||||
where
|
||||
f :: Game -> Direction
|
||||
f game = case tileAt (gameBoard game) (snakeHead game) of
|
||||
Snake HEAD_DOWN -> DOWN
|
||||
Snake HEAD_LEFT -> LEFT
|
||||
Snake HEAD_UP -> UP
|
||||
Snake HEAD_RIGHT -> RIGHT
|
||||
_ -> error "Invalid snake head tile"
|
||||
|
||||
moveHead :: Direction -> GameState ()
|
||||
moveHead direction = do
|
||||
pos <- gets snakeHead
|
||||
destination <- shiftPos pos direction
|
||||
board <- gets gameBoard
|
||||
headTile <- gets ((`tileAt` pos) . gameBoard)
|
||||
let orientation = case headTile of
|
||||
Snake x -> x
|
||||
_ -> error "Invalid snake head tile"
|
||||
let modifiedBoard = board // [(pos, Snake $ getGrownHead orientation direction), (destination, Snake $ getNewHead direction)]
|
||||
modify (\s -> s {gameBoard=modifiedBoard, snakeHead=destination})
|
||||
|
||||
getGrownHead :: SnakeOrientation -> Direction -> SnakeOrientation
|
||||
getGrownHead HEAD_UP UP = VERTICAL
|
||||
getGrownHead HEAD_UP LEFT = TURN_DOWN_LEFT
|
||||
getGrownHead HEAD_UP RIGHT = TURN_DOWN_RIGHT
|
||||
getGrownHead HEAD_RIGHT RIGHT = HORIZONTAL
|
||||
getGrownHead HEAD_RIGHT UP = TURN_UP_LEFT
|
||||
getGrownHead HEAD_RIGHT DOWN = TURN_DOWN_LEFT
|
||||
getGrownHead HEAD_DOWN DOWN = VERTICAL
|
||||
getGrownHead HEAD_DOWN RIGHT = TURN_UP_RIGHT
|
||||
getGrownHead HEAD_DOWN LEFT = TURN_UP_LEFT
|
||||
getGrownHead HEAD_LEFT LEFT = HORIZONTAL
|
||||
getGrownHead HEAD_LEFT DOWN = TURN_DOWN_RIGHT
|
||||
getGrownHead HEAD_LEFT UP = TURN_UP_RIGHT
|
||||
getGrownHead _ _ = error "Invalid getGrownHead arguments"
|
||||
|
||||
getNewHead :: Direction -> SnakeOrientation
|
||||
getNewHead UP = HEAD_UP
|
||||
getNewHead RIGHT = HEAD_RIGHT
|
||||
getNewHead DOWN = HEAD_DOWN
|
||||
getNewHead LEFT = HEAD_LEFT
|
||||
|
||||
shiftPos :: Pos -> Direction -> GameState Pos
|
||||
shiftPos (x, y) direction = do
|
||||
let (dx, dy) = getDelta direction
|
||||
size <- gets gameBoardSize
|
||||
pure $ wrapPos size (x + dx, y + dy)
|
||||
|
||||
|
||||
shrinkSnake :: GameState ()
|
||||
shrinkSnake = do
|
||||
pos <- gets snakeTail
|
||||
tile <- gets ((`tileAt` pos) . gameBoard)
|
||||
let direction = case tile of
|
||||
Snake TAIL_UP -> UP
|
||||
Snake TAIL_RIGHT -> RIGHT
|
||||
Snake TAIL_DOWN -> DOWN
|
||||
Snake TAIL_LEFT -> LEFT
|
||||
_ -> error "Invalid snake tail tile"
|
||||
destination <- shiftPos pos direction
|
||||
board <- gets gameBoard
|
||||
destinationTile <- gets ((`tileAt` destination) . gameBoard)
|
||||
let orientation = case destinationTile of
|
||||
Snake x -> x
|
||||
_ -> error "Invalid snake segment tile"
|
||||
let modifiedBoard = board // [(pos, Empty), (destination, Snake $ getNewTail orientation direction)]
|
||||
modify (\s -> s {gameBoard=modifiedBoard, snakeTail=destination})
|
||||
|
||||
getNewTail :: SnakeOrientation -> Direction -> SnakeOrientation
|
||||
getNewTail HEAD_UP UP = TAIL_UP
|
||||
getNewTail HEAD_RIGHT RIGHT = TAIL_RIGHT
|
||||
getNewTail HEAD_DOWN DOWN = TAIL_DOWN
|
||||
getNewTail HEAD_LEFT LEFT = TAIL_LEFT
|
||||
getNewTail TURN_UP_RIGHT LEFT = TAIL_UP
|
||||
getNewTail TURN_UP_RIGHT DOWN = TAIL_RIGHT
|
||||
getNewTail TURN_DOWN_RIGHT LEFT = TAIL_DOWN
|
||||
getNewTail TURN_DOWN_RIGHT UP = TAIL_RIGHT
|
||||
getNewTail TURN_DOWN_LEFT RIGHT = TAIL_DOWN
|
||||
getNewTail TURN_DOWN_LEFT UP = TAIL_LEFT
|
||||
getNewTail TURN_UP_LEFT RIGHT = TAIL_UP
|
||||
getNewTail TURN_UP_LEFT DOWN = TAIL_LEFT
|
||||
getNewTail HORIZONTAL RIGHT = TAIL_RIGHT
|
||||
getNewTail HORIZONTAL LEFT = TAIL_LEFT
|
||||
getNewTail VERTICAL UP = TAIL_UP
|
||||
getNewTail VERTICAL DOWN = TAIL_DOWN
|
||||
getNewTail o d = error ("Invalid getNewTail arguments: " ++ show o ++ " " ++ show d)
|
||||
|
||||
data MovementResult = IntoApple | IntoSnake | IntoEmpty deriving (Eq, Show)
|
||||
|
||||
data SnakeOrientation =
|
||||
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)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue