Score rendering
This commit is contained in:
parent
1dd23d6e62
commit
ffb2a087e1
8 changed files with 203 additions and 119 deletions
|
|
@ -1,6 +1,5 @@
|
|||
{-# LANGUAGE FlexibleContexts #-}
|
||||
module SnakeLib (
|
||||
MovementInput (..),
|
||||
module Snake (
|
||||
Tile (..),
|
||||
Pos,
|
||||
Board,
|
||||
|
|
@ -10,18 +9,22 @@ module SnakeLib (
|
|||
|
||||
runTick,
|
||||
|
||||
MovementInput (..),
|
||||
MovementResult (..),
|
||||
|
||||
SnakeSegmentOrientation (..),
|
||||
Direction (..),
|
||||
growHead,
|
||||
shrinkTail
|
||||
shrinkTail,
|
||||
|
||||
snakeSegmentCount
|
||||
) where
|
||||
|
||||
import Data.Array
|
||||
import Control.Monad.State
|
||||
import Control.Monad (when, unless)
|
||||
import Control.Monad (when)
|
||||
import System.Random (randomRIO)
|
||||
|
||||
data Tile = SnakeSegment SnakeSegmentOrientation | Apple | Empty deriving (Eq, Show)
|
||||
import Tile
|
||||
|
||||
type Pos = (Int, Int)
|
||||
|
||||
|
|
@ -29,6 +32,18 @@ type Board = Array Pos Tile
|
|||
|
||||
data Game = Game {gameBoard :: Board, gameBoardSize :: (Int, Int), snakeHead :: Pos, snakeTail :: Pos}
|
||||
|
||||
data MovementInput = UpPressed | RightPressed | DownPressed | LeftPressed | NothingPressed deriving (Eq, Show)
|
||||
|
||||
instance Semigroup MovementInput where
|
||||
(<>) l NothingPressed = l
|
||||
NothingPressed <> r = r
|
||||
l <> _ = l
|
||||
|
||||
instance Monoid MovementInput where
|
||||
mempty = NothingPressed
|
||||
|
||||
data MovementResult = IntoApple | IntoSnake | IntoEmpty deriving (Eq, Show)
|
||||
|
||||
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]]
|
||||
|
||||
|
|
@ -51,7 +66,7 @@ gameTick input = do
|
|||
|
||||
advanceSnake :: MonadState Game m => MovementInput -> m MovementResult
|
||||
advanceSnake input = do
|
||||
idleDirection <- headDirection
|
||||
idleDirection <- getHeadDirection
|
||||
let inputDirection = case input of
|
||||
UpPressed -> UP
|
||||
RightPressed -> RIGHT
|
||||
|
|
@ -67,8 +82,8 @@ advanceSnake input = do
|
|||
Empty -> moveHead direction >> pure IntoEmpty
|
||||
SnakeSegment _ -> pure IntoSnake
|
||||
|
||||
headDirection :: MonadState Game m => m Direction
|
||||
headDirection = gets f
|
||||
getHeadDirection :: MonadState Game m => m Direction
|
||||
getHeadDirection = gets f
|
||||
where
|
||||
f :: Game -> Direction
|
||||
f game = case tileAt (gameBoard game) (snakeHead game) of
|
||||
|
|
@ -90,27 +105,6 @@ moveHead direction = do
|
|||
let modifiedBoard = board // [(pos, SnakeSegment $ growHead orientation direction), (destination, SnakeSegment $ getNewHead direction)]
|
||||
modify (\s -> s {gameBoard=modifiedBoard, snakeHead=destination})
|
||||
|
||||
growHead :: SnakeSegmentOrientation -> Direction -> SnakeSegmentOrientation
|
||||
growHead HEAD_UP UP = VERTICAL
|
||||
growHead HEAD_UP LEFT = TURN_DOWN_LEFT
|
||||
growHead HEAD_UP RIGHT = TURN_DOWN_RIGHT
|
||||
growHead HEAD_RIGHT RIGHT = HORIZONTAL
|
||||
growHead HEAD_RIGHT UP = TURN_UP_LEFT
|
||||
growHead HEAD_RIGHT DOWN = TURN_DOWN_LEFT
|
||||
growHead HEAD_DOWN DOWN = VERTICAL
|
||||
growHead HEAD_DOWN RIGHT = TURN_UP_RIGHT
|
||||
growHead HEAD_DOWN LEFT = TURN_UP_LEFT
|
||||
growHead HEAD_LEFT LEFT = HORIZONTAL
|
||||
growHead HEAD_LEFT DOWN = TURN_DOWN_RIGHT
|
||||
growHead HEAD_LEFT UP = TURN_UP_RIGHT
|
||||
growHead _ _ = error "Invalid growHead arguments"
|
||||
|
||||
getNewHead :: Direction -> SnakeSegmentOrientation
|
||||
getNewHead UP = HEAD_UP
|
||||
getNewHead RIGHT = HEAD_RIGHT
|
||||
getNewHead DOWN = HEAD_DOWN
|
||||
getNewHead LEFT = HEAD_LEFT
|
||||
|
||||
shrinkSnake :: MonadState Game m => m ()
|
||||
shrinkSnake = do
|
||||
pos <- gets snakeTail
|
||||
|
|
@ -130,25 +124,6 @@ shrinkSnake = do
|
|||
let modifiedBoard = board // [(pos, Empty), (destination, SnakeSegment $ shrinkTail orientation direction)]
|
||||
modify (\s -> s {gameBoard=modifiedBoard, snakeTail=destination})
|
||||
|
||||
shrinkTail :: SnakeSegmentOrientation -> Direction -> SnakeSegmentOrientation
|
||||
shrinkTail HEAD_UP UP = TAIL_UP
|
||||
shrinkTail HEAD_RIGHT RIGHT = TAIL_RIGHT
|
||||
shrinkTail HEAD_DOWN DOWN = TAIL_DOWN
|
||||
shrinkTail HEAD_LEFT LEFT = TAIL_LEFT
|
||||
shrinkTail TURN_UP_RIGHT LEFT = TAIL_UP
|
||||
shrinkTail TURN_UP_RIGHT DOWN = TAIL_RIGHT
|
||||
shrinkTail TURN_DOWN_RIGHT LEFT = TAIL_DOWN
|
||||
shrinkTail TURN_DOWN_RIGHT UP = TAIL_RIGHT
|
||||
shrinkTail TURN_DOWN_LEFT RIGHT = TAIL_DOWN
|
||||
shrinkTail TURN_DOWN_LEFT UP = TAIL_LEFT
|
||||
shrinkTail TURN_UP_LEFT RIGHT = TAIL_UP
|
||||
shrinkTail TURN_UP_LEFT DOWN = TAIL_LEFT
|
||||
shrinkTail HORIZONTAL RIGHT = TAIL_RIGHT
|
||||
shrinkTail HORIZONTAL LEFT = TAIL_LEFT
|
||||
shrinkTail VERTICAL UP = TAIL_UP
|
||||
shrinkTail VERTICAL DOWN = TAIL_DOWN
|
||||
shrinkTail o d = error ("Invalid shrinkTail arguments: " ++ show o ++ " " ++ show d)
|
||||
|
||||
spawnApple :: (MonadState Game m, MonadIO m) => m ()
|
||||
spawnApple = do
|
||||
(w, h) <- gets gameBoardSize
|
||||
|
|
@ -158,6 +133,12 @@ spawnApple = do
|
|||
Empty -> modify (\s -> s {gameBoard = gameBoard s // [(pos, Apple)]})
|
||||
_ -> spawnApple
|
||||
|
||||
snakeSegmentCount :: Game -> Int
|
||||
snakeSegmentCount = length . filter isSnakeSegment . elems . gameBoard
|
||||
|
||||
isSnakeSegment :: Tile -> Bool
|
||||
isSnakeSegment (SnakeSegment _) = True
|
||||
isSnakeSegment _ = False
|
||||
tileAt :: Board -> Pos -> Tile
|
||||
tileAt board (x, y) = (board ! (x, y))
|
||||
|
||||
|
|
@ -174,36 +155,5 @@ shiftPos (x, y) direction = do
|
|||
size <- gets gameBoardSize
|
||||
pure $ wrapPos size (x + dx, y + dy)
|
||||
|
||||
data MovementInput = UpPressed | RightPressed | DownPressed | LeftPressed | NothingPressed deriving (Eq, Show)
|
||||
|
||||
instance Semigroup MovementInput where
|
||||
(<>) l NothingPressed = l
|
||||
NothingPressed <> r = r
|
||||
l <> _ = l
|
||||
|
||||
instance Monoid MovementInput where
|
||||
mempty = NothingPressed
|
||||
|
||||
data MovementResult = IntoApple | IntoSnake | IntoEmpty deriving (Eq, Show)
|
||||
|
||||
data SnakeSegmentOrientation =
|
||||
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)
|
||||
74
src/Tile.hs
Normal file
74
src/Tile.hs
Normal file
|
|
@ -0,0 +1,74 @@
|
|||
module Tile (
|
||||
Tile (..),
|
||||
SnakeSegmentOrientation (..),
|
||||
Direction (..),
|
||||
areOpposite,
|
||||
growHead,
|
||||
getNewHead,
|
||||
shrinkTail,
|
||||
getDelta
|
||||
) where
|
||||
|
||||
data Tile = SnakeSegment SnakeSegmentOrientation | Apple | Empty deriving (Eq, Show)
|
||||
|
||||
data SnakeSegmentOrientation =
|
||||
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
|
||||
|
||||
growHead :: SnakeSegmentOrientation -> Direction -> SnakeSegmentOrientation
|
||||
growHead HEAD_UP UP = VERTICAL
|
||||
growHead HEAD_UP LEFT = TURN_DOWN_LEFT
|
||||
growHead HEAD_UP RIGHT = TURN_DOWN_RIGHT
|
||||
growHead HEAD_RIGHT RIGHT = HORIZONTAL
|
||||
growHead HEAD_RIGHT UP = TURN_UP_LEFT
|
||||
growHead HEAD_RIGHT DOWN = TURN_DOWN_LEFT
|
||||
growHead HEAD_DOWN DOWN = VERTICAL
|
||||
growHead HEAD_DOWN RIGHT = TURN_UP_RIGHT
|
||||
growHead HEAD_DOWN LEFT = TURN_UP_LEFT
|
||||
growHead HEAD_LEFT LEFT = HORIZONTAL
|
||||
growHead HEAD_LEFT DOWN = TURN_DOWN_RIGHT
|
||||
growHead HEAD_LEFT UP = TURN_UP_RIGHT
|
||||
growHead _ _ = error "Invalid growHead arguments"
|
||||
|
||||
getNewHead :: Direction -> SnakeSegmentOrientation
|
||||
getNewHead UP = HEAD_UP
|
||||
getNewHead RIGHT = HEAD_RIGHT
|
||||
getNewHead DOWN = HEAD_DOWN
|
||||
getNewHead LEFT = HEAD_LEFT
|
||||
|
||||
shrinkTail :: SnakeSegmentOrientation -> Direction -> SnakeSegmentOrientation
|
||||
shrinkTail HEAD_UP UP = TAIL_UP
|
||||
shrinkTail HEAD_RIGHT RIGHT = TAIL_RIGHT
|
||||
shrinkTail HEAD_DOWN DOWN = TAIL_DOWN
|
||||
shrinkTail HEAD_LEFT LEFT = TAIL_LEFT
|
||||
shrinkTail TURN_UP_RIGHT LEFT = TAIL_UP
|
||||
shrinkTail TURN_UP_RIGHT DOWN = TAIL_RIGHT
|
||||
shrinkTail TURN_DOWN_RIGHT LEFT = TAIL_DOWN
|
||||
shrinkTail TURN_DOWN_RIGHT UP = TAIL_RIGHT
|
||||
shrinkTail TURN_DOWN_LEFT RIGHT = TAIL_DOWN
|
||||
shrinkTail TURN_DOWN_LEFT UP = TAIL_LEFT
|
||||
shrinkTail TURN_UP_LEFT RIGHT = TAIL_UP
|
||||
shrinkTail TURN_UP_LEFT DOWN = TAIL_LEFT
|
||||
shrinkTail HORIZONTAL RIGHT = TAIL_RIGHT
|
||||
shrinkTail HORIZONTAL LEFT = TAIL_LEFT
|
||||
shrinkTail VERTICAL UP = TAIL_UP
|
||||
shrinkTail VERTICAL DOWN = TAIL_DOWN
|
||||
shrinkTail o d = error ("Invalid shrinkTail arguments: " ++ show o ++ " " ++ show d)
|
||||
|
||||
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