101 lines
4.0 KiB
Haskell
101 lines
4.0 KiB
Haskell
{-# LANGUAGE TemplateHaskell #-}
|
|
import Control.Monad.Random (getRandomRs)
|
|
import Graphics.Gloss.Interface.Pure.Game
|
|
import Lens.Micro ((%~), (^.), (&), set)
|
|
import Lens.Micro.TH (makeLenses)
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- all data types
|
|
|
|
data Snake = Snake { _body :: [Point], _direction :: Point }
|
|
makeLenses ''Snake
|
|
|
|
data World = World { _snake :: Snake , _food :: [Point]
|
|
, _score :: Int , _maxScore :: Int }
|
|
makeLenses ''World
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- everything snake can do
|
|
|
|
moves (Snake b d) = Snake (step b d : init b) d
|
|
eats (Snake b d) = Snake (step b d : b) d
|
|
bites (Snake b _) = any (== head b)
|
|
step ((x,y):_) (a,b) = (x+a, y+b)
|
|
|
|
turn (x',y') (Snake b (x,y)) | (x+x',y+y') == (0,0) = Snake b (x,y)
|
|
| otherwise = Snake b (x',y')
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- all randomness
|
|
|
|
createWorld = do xs <- map fromIntegral <$> getRandomRs (2, 38 :: Int)
|
|
ys <- map fromIntegral <$> getRandomRs (2, 38 :: Int)
|
|
return (Ok, World snake (zip xs ys) 0 0)
|
|
where
|
|
snake = Snake [(20, 20)] (1,0)
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- A tyny DSL for declarative description of business logic
|
|
|
|
data Status = Ok | Fail | Stop
|
|
|
|
continue = \x -> (Ok, x)
|
|
stop = \x -> (Stop, x)
|
|
f >>> g = \x -> case f x of { (Ok, y) -> g y; b -> b } -- chain composition
|
|
f <|> g = \x -> case f x of { (Fail, _) -> g x; b -> b } -- alternative
|
|
p ==> f = \x -> if p x then f x else (Fail, x) -- condition
|
|
l .& f = continue . (l %~ f) -- modification
|
|
l .= y = continue . set l y -- setting
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- all business logic
|
|
|
|
updateWorld _ = id >>> (snakeEats <|> snakeMoves)
|
|
where
|
|
snakeEats = (snakeFindsFood ==> (snake .& eats)) >>>
|
|
(score .& (+1)) >>> (food .& tail)
|
|
|
|
snakeMoves = (snakeBitesTail ==> stop) <|>
|
|
(snakeHitsWall ==> stop) <|>
|
|
(snake .& moves)
|
|
|
|
snakeFindsFood w = (w^.snake & moves) `bites` (w^.food & take 1)
|
|
snakeBitesTail w = (w^.snake) `bites` (w^.snake.body & tail)
|
|
snakeHitsWall w = (w^.snake.body) & head & isOutside
|
|
isOutside (x,y) = or [x <= 0, 40 <= x, y <= 0, 40 <= y]
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- all event handing
|
|
|
|
handleEvents e (s,w) = f w
|
|
where f = case s of
|
|
Ok -> case e of
|
|
EventKey (SpecialKey k) _ _ _ -> case k of
|
|
KeyRight -> snake .& turn (1,0)
|
|
KeyLeft -> snake .& turn (-1,0)
|
|
KeyUp -> snake .& turn (0,1)
|
|
KeyDown -> snake .& turn (0,-1)
|
|
_-> continue
|
|
_-> continue
|
|
_-> \w -> w & ((snake.body) .= [(20,20)]) >>>
|
|
(maxScore .& max (w^.score)) >>> (score .= 0)
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- all graphics
|
|
|
|
renderWorld (s, w) = pictures [frame, color c drawSnake, drawFood, showScore]
|
|
where c = case s of { Ok -> orange; _-> red }
|
|
drawSnake = foldMap (rectangleSolid 10 10 `at`) (w^.snake.body)
|
|
drawFood = color blue $ circleSolid 5 `at` (w^.food & head)
|
|
frame = color black $ rectangleWire 400 400
|
|
showScore = color orange $ scale 0.2 0.2 $ txt `at` (-80,130)
|
|
txt = Text $ mconcat ["Score: ", w^.score & show
|
|
," Maximal score: ", w^.maxScore & show]
|
|
at p (x,y) = Translate (10*x-200) (10*y-200) p
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
main = do world <- createWorld
|
|
play inW white 7 world renderWorld handleEvents updateWorld
|
|
where inW = InWindow "The Snake" (400, 400) (10, 10)
|