diff --git a/app/Graphics.hs b/app/Graphics.hs new file mode 100644 index 0000000..b797f0d --- /dev/null +++ b/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 + diff --git a/app/Main.hs b/app/Main.hs index 60d904e..b2da535 100644 --- a/app/Main.hs +++ b/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!" - MyLib.someFunc + initializeAll + 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) + diff --git a/assets/spritesheet.png b/assets/spritesheet.png new file mode 100644 index 0000000..d16f2bf Binary files /dev/null and b/assets/spritesheet.png differ diff --git a/snake-hs.cabal b/snake-hs.cabal index 609d1d8..35df11e 100644 --- a/snake-hs.cabal +++ b/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 diff --git a/src/MyLib.hs b/src/MyLib.hs deleted file mode 100644 index e657c44..0000000 --- a/src/MyLib.hs +++ /dev/null @@ -1,4 +0,0 @@ -module MyLib (someFunc) where - -someFunc :: IO () -someFunc = putStrLn "someFunc" diff --git a/src/SnakeLib.hs b/src/SnakeLib.hs new file mode 100644 index 0000000..41f0a15 --- /dev/null +++ b/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