Last active
April 21, 2018 23:23
-
-
Save Garciat/6fe00349f5c6b3b4c34d5d055eebb029 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
import Control.Monad (guard, when) | |
import Data.Array (Array, (!), (//), bounds, listArray) | |
import System.Console.ANSI | |
import System.IO (stdin, hReady) | |
import System.Random | |
import System.Timeout (timeout) | |
import Debug.Trace | |
data Pos | |
= Pos | |
{ posX :: Int | |
, posY :: Int | |
} | |
deriving (Show, Eq) | |
posPair :: Pos -> (Int, Int) | |
posPair (Pos x y) = (x, y) | |
data Delta | |
= Delta | |
{ deltaX :: Int | |
, deltaY :: Int | |
} | |
deriving (Show, Eq) | |
data Dir | |
= DirN | |
| DirE | |
| DirS | |
| DirW | |
deriving (Show, Eq, Enum) | |
dirDelta :: Dir -> Delta | |
dirDelta DirN = Delta 0 (-1) | |
dirDelta DirE = Delta 1 0 | |
dirDelta DirS = Delta 0 1 | |
dirDelta DirW = Delta (-1) 0 | |
(.+) :: Pos -> Delta -> Pos | |
Pos x y .+ Delta dx dy = Pos (x + dx) (y + dy) | |
type Snake = [Pos] | |
snakeHeadPair :: Snake -> (Int, Int) | |
snakeHeadPair = posPair . head | |
data Block | |
= Empty | |
| Wall | |
| Snake | |
| Food Int | |
deriving (Show, Eq) | |
type StageSize = (Int, Int) | |
type Stage = Array StageSize Block | |
(.%) :: Pos -> StageSize -> Pos | |
Pos x y .% (w, h) = Pos (f x w) (f y h) | |
where | |
f i r = (i + r) `mod` r | |
moveSnake :: StageSize -> Dir -> Snake -> Snake | |
moveSnake sb dir snake = (head snake .+ dirDelta dir .% sb) : (init snake) | |
growSnake :: Int -> Snake -> Snake | |
growSnake n snake = snake ++ replicate n (last snake) | |
data Game | |
= Game | |
{ gameStage :: Stage | |
, gameScore :: Int | |
, gameSnake :: Snake | |
, gameDir :: Dir | |
, gameOver :: Bool | |
, gameRandom :: StdGen | |
} | |
deriving Show | |
instance RandomGen Game where | |
next game = | |
let (x, gen') = next $ gameRandom game | |
in (x, game { gameRandom = gen' }) | |
split game = | |
let (g1, g2) = split $ gameRandom game | |
in (game { gameRandom = g1 }, game { gameRandom = g2 }) | |
genRange = genRange . gameRandom | |
gameBounds :: Game -> (StageSize, StageSize) | |
gameBounds = bounds . gameStage | |
gameSize :: Game -> StageSize | |
gameSize game = | |
let (w, h) = snd (gameBounds game) | |
in (w+1, h+1) | |
mapGameSnake :: (Snake -> Snake) -> Game -> Game | |
mapGameSnake f game = game { gameSnake = f (gameSnake game) } | |
mapGameStage :: (Stage -> Stage) -> Game -> Game | |
mapGameStage f game = game { gameStage = f (gameStage game) } | |
changeDir :: Dir -> Game -> Game | |
changeDir dir game = game { gameDir = dir } | |
endGame :: Game -> Game | |
endGame game = game { gameOver = True } | |
gameGrowSnake :: Int -> Game -> Game | |
gameGrowSnake n = mapGameSnake (growSnake n) | |
gameBlock :: Game -> Pos -> Block | |
gameBlock game pos = | |
case gameStage game ! posPair pos of | |
Empty | pos `elem` tail (gameSnake game) -> Snake | |
block -> block | |
gameBlockDisplay :: Game -> Pos -> Block | |
gameBlockDisplay game pos | |
| pos `elem` gameSnake game = Snake | |
| otherwise = gameStage game ! posPair pos | |
gameSnakeHead :: Game -> Pos | |
gameSnakeHead = head . gameSnake | |
gameSnakeHeadBlock :: Game -> Block | |
gameSnakeHeadBlock game = gameBlock game (gameSnakeHead game) | |
gamePut :: Pos -> Block -> Game -> Game | |
gamePut pos block = mapGameStage (// [(posPair pos, block)]) | |
gameAddFood :: Int -> Pos -> Game -> Game | |
gameAddFood n pos = gamePut pos (Food n) | |
gameRandomPos :: Game -> (Pos, Game) | |
gameRandomPos game = | |
let (x, game') = randomR (0, w-1) game | |
(y, game'') = randomR (0, h-1) game' | |
in (Pos x y, game'') | |
where | |
(w, h) = gameSize game | |
-- should be Maybe | |
gameRandomEmptyPos :: Game -> (Pos, Game) | |
gameRandomEmptyPos game = | |
let (pos, game') = gameRandomPos game | |
in | |
case gameBlockDisplay game pos of | |
Empty -> (pos, game') | |
otherwise -> gameRandomEmptyPos game' | |
gameAddRandomFood :: Game -> Game | |
gameAddRandomFood game = | |
let (pos, game') = gameRandomEmptyPos game | |
in gameAddFood 3 (traceShowId pos) game' | |
gameClearAtHead :: Game -> Game | |
gameClearAtHead game = gamePut (gameSnakeHead game) Empty game | |
tickSnake :: Game -> Game | |
tickSnake game = mapGameSnake (moveSnake (gameSize game) (gameDir game)) game | |
tickCollision :: Game -> Game | |
tickCollision game = | |
case gameSnakeHeadBlock game of | |
Wall -> endGame game | |
Snake -> endGame game | |
Empty -> game | |
Food n -> gameAddRandomFood . gameClearAtHead . gameGrowSnake n $ game | |
tick :: Game -> Game | |
tick game | |
| gameOver game = game | |
| otherwise = tickCollision . tickSnake $ game | |
emptyStage :: Int -> Int -> Stage | |
emptyStage w h = listArray ((0, 0), (w-1, h-1)) (repeat Empty) | |
newGame :: Int -> Int -> StdGen -> Game | |
newGame w h gen = gameAddFood 3 (Pos 4 0) game | |
where | |
game = | |
Game | |
{ gameStage = emptyStage w h | |
, gameScore = 0 | |
, gameSnake = [Pos 0 0] | |
, gameDir = DirE | |
, gameOver = False | |
, gameRandom = gen | |
} | |
displayGame :: Game -> String | |
displayGame game = | |
unlines $ map row [0..h-1] | |
where | |
(w, h) = gameSize game | |
row i = map (cell i) [0..w-1] | |
cell i j = | |
case gameBlockDisplay game (Pos j i) of | |
Wall -> '#' | |
Food _ -> '%' | |
Snake -> '@' | |
Empty -> '.' | |
--- | |
parseDir :: String -> Maybe Dir | |
parseDir key = | |
case key of | |
"\ESC[A" -> Just DirN | |
"\ESC[B" -> Just DirS | |
"\ESC[C" -> Just DirE | |
"\ESC[D" -> Just DirW | |
_ -> Nothing | |
getKey :: IO [Char] | |
getKey = reverse <$> getKey' "" | |
where | |
getKey' chars = do | |
char <- getChar | |
more <- hReady stdin | |
(if more then getKey' else return) (char:chars) | |
readDir :: IO (Maybe Dir) | |
readDir = parseDir <$> getKey | |
play :: Game -> IO () | |
play game | |
| gameOver game = putStrLn "You lost ):" | |
| otherwise = do | |
clearScreen | |
putStrLn "" | |
putStrLn (displayGame game) | |
action <- timeout 200000 readDir | |
case action of | |
Just (Just dir) -> play (tick . changeDir dir $ game) | |
otherwise -> play (tick game) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment