Add true randomness
Previously, randomness was faked via bad pseudo-randomness code, so let's refactor some of this to add true randomness support.
This commit is contained in:
parent
7c61ddb24f
commit
a6a70e5dca
|
@ -12,5 +12,7 @@ executable snake
|
||||||
default-language: GHC2021
|
default-language: GHC2021
|
||||||
default-extensions: Arrows
|
default-extensions: Arrows
|
||||||
build-depends: base,
|
build-depends: base,
|
||||||
|
mtl,
|
||||||
|
random,
|
||||||
dunai,
|
dunai,
|
||||||
gloss
|
gloss
|
||||||
|
|
|
@ -1,10 +1,10 @@
|
||||||
{-# LANGUAGE Arrows #-}
|
{-# LANGUAGE Arrows #-}
|
||||||
{-# LANGUAGE OverloadedRecordDot #-}
|
{-# LANGUAGE OverloadedRecordDot #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
|
||||||
|
|
||||||
module Game.Engine where
|
module Game.Engine where
|
||||||
|
|
||||||
import Control.Monad (guard)
|
import Control.Monad (guard)
|
||||||
|
import Control.Monad.Trans
|
||||||
import Control.Monad.Trans.MSF.Maybe
|
import Control.Monad.Trans.MSF.Maybe
|
||||||
import Control.Monad.Trans.MSF.Reader
|
import Control.Monad.Trans.MSF.Reader
|
||||||
import Control.Monad.Trans.MSF.Writer
|
import Control.Monad.Trans.MSF.Writer
|
||||||
|
@ -43,7 +43,7 @@ handleEvents = mapMaybe getDir <$> getKeys
|
||||||
|
|
||||||
-- * Core game engine
|
-- * Core game engine
|
||||||
|
|
||||||
tickState :: Maybe Direction -> GameState -> Maybe GameState
|
tickState :: Maybe Direction -> GameState -> MaybeT IO GameState
|
||||||
tickState dir state =
|
tickState dir state =
|
||||||
let moveDir = setDir state.moveDir dir
|
let moveDir = setDir state.moveDir dir
|
||||||
newBlock = movePos moveDir $ head state.snakePos
|
newBlock = movePos moveDir $ head state.snakePos
|
||||||
|
@ -56,19 +56,16 @@ tickState dir state =
|
||||||
isHit = head snakePos `notElem` tail snakePos
|
isHit = head snakePos `notElem` tail snakePos
|
||||||
berryPos =
|
berryPos =
|
||||||
if hitBerry
|
if hitBerry
|
||||||
then
|
then randomPos
|
||||||
( (fst state.berryPos * 80 `div` 3) `mod` 15,
|
else pure state.berryPos
|
||||||
(snd state.berryPos * 75 `div` 6) `mod` 15
|
in MaybeT $ (guard isHit $>) <$> (GameState snakePos moveDir <$> berryPos)
|
||||||
)
|
|
||||||
else state.berryPos
|
|
||||||
in guard isHit $> GameState {..}
|
|
||||||
|
|
||||||
tick :: Monad m => MSF (MaybeT (DrawerT m)) (Maybe Direction) GameState
|
tick :: MonadIO m => MSF (MaybeT (DrawerT m)) (Maybe Direction) GameState
|
||||||
tick = feedback initialState $ proc (dir, state) -> do
|
tick = feedbackM (liftIO randomState) $ proc (dir, state) -> do
|
||||||
newstate <- maybeExit -< tickState dir state
|
newstate <- arrM (mapMaybeT (lift . lift . liftIO) . uncurry tickState) -< (dir, state)
|
||||||
returnA -< (newstate, newstate)
|
returnA -< (newstate, newstate)
|
||||||
|
|
||||||
gameSF :: Monad m => MSF (MaybeT (DrawerT m)) () GameState
|
gameSF :: MonadIO m => MSF (MaybeT (DrawerT m)) () GameState
|
||||||
gameSF = proc () -> do
|
gameSF = proc () -> do
|
||||||
-- A "tick" is each frame that the snake advances
|
-- A "tick" is each frame that the snake advances
|
||||||
n <- count -< ()
|
n <- count -< ()
|
||||||
|
@ -81,7 +78,7 @@ gameSF = proc () -> do
|
||||||
-- only run `tick` whenever there's a tick
|
-- only run `tick` whenever there's a tick
|
||||||
pauseMSF undefined tick -< (dir, isTick)
|
pauseMSF undefined tick -< (dir, isTick)
|
||||||
|
|
||||||
mainSF :: Monad m => MSF (DrawerT m) () ()
|
mainSF :: MonadIO m => MSF (DrawerT m) () ()
|
||||||
mainSF = proc () -> do
|
mainSF = proc () -> do
|
||||||
keys <- getKeys -< ()
|
keys <- getKeys -< ()
|
||||||
let esc = SpecialKey KeyEsc `elem` keys
|
let esc = SpecialKey KeyEsc `elem` keys
|
||||||
|
|
|
@ -1,6 +1,11 @@
|
||||||
|
{-# LANGUAGE LambdaCase #-}
|
||||||
|
|
||||||
module Game.State where
|
module Game.State where
|
||||||
|
|
||||||
data Direction = U | D | L | R
|
import System.Random
|
||||||
|
import Control.Monad
|
||||||
|
|
||||||
|
data Direction = U | D | L | R deriving (Eq)
|
||||||
|
|
||||||
movePos :: Direction -> (Int, Int) -> (Int, Int)
|
movePos :: Direction -> (Int, Int) -> (Int, Int)
|
||||||
movePos U (x, y) = (x, y + 1)
|
movePos U (x, y) = (x, y + 1)
|
||||||
|
@ -8,16 +13,15 @@ movePos D (x, y) = (x, y - 1)
|
||||||
movePos L (x, y) = (x - 1, y)
|
movePos L (x, y) = (x - 1, y)
|
||||||
movePos R (x, y) = (x + 1, y)
|
movePos R (x, y) = (x + 1, y)
|
||||||
|
|
||||||
opposite :: Direction -> Direction -> Bool
|
opposite :: Direction -> Direction
|
||||||
opposite U D = True
|
opposite U = D
|
||||||
opposite D U = True
|
opposite D = U
|
||||||
opposite L R = True
|
opposite L = R
|
||||||
opposite R L = True
|
opposite R = L
|
||||||
opposite _ _ = False
|
|
||||||
|
|
||||||
setDir :: Direction -> Maybe Direction -> Direction
|
setDir :: Direction -> Maybe Direction -> Direction
|
||||||
setDir d Nothing = d
|
setDir d Nothing = d
|
||||||
setDir d (Just d') = if opposite d d' then d else d'
|
setDir d (Just d') = if opposite d == d' then d else d'
|
||||||
|
|
||||||
data GameState = GameState
|
data GameState = GameState
|
||||||
{ snakePos :: [(Int, Int)],
|
{ snakePos :: [(Int, Int)],
|
||||||
|
@ -25,5 +29,21 @@ data GameState = GameState
|
||||||
berryPos :: (Int, Int)
|
berryPos :: (Int, Int)
|
||||||
}
|
}
|
||||||
|
|
||||||
initialState :: GameState
|
initialLength :: Int
|
||||||
initialState = GameState [(4, 5), (4, 4), (5, 4)] R (3, 3)
|
initialLength = 3
|
||||||
|
|
||||||
|
randomPos :: IO (Int, Int)
|
||||||
|
randomPos = (,) <$> randomRIO (-10, 10) <*> randomRIO (-10, 10)
|
||||||
|
|
||||||
|
randomState :: IO GameState
|
||||||
|
randomState = do
|
||||||
|
let randomDirection =
|
||||||
|
(\case
|
||||||
|
1 -> U
|
||||||
|
2 -> D
|
||||||
|
3 -> L
|
||||||
|
4 -> R) <$> randomRIO @Int (1,4)
|
||||||
|
dirs <- replicateM (initialLength - 1) randomDirection
|
||||||
|
hd <- randomPos
|
||||||
|
let snake = scanr movePos hd dirs
|
||||||
|
GameState snake <$> randomDirection <*> randomPos
|
||||||
|
|
|
@ -52,6 +52,12 @@ draw = arrM tell
|
||||||
|
|
||||||
-- * MSF convenience functions
|
-- * MSF convenience functions
|
||||||
|
|
||||||
|
feedbackM :: Monad m => m c -> MSF m (a, c) (b, c) -> MSF m a b
|
||||||
|
feedbackM init msf = feedback Nothing $ proc (x, state) -> do
|
||||||
|
state' <- arrM (maybe init pure) -< state
|
||||||
|
(y, newstate) <- msf -< (x, state')
|
||||||
|
returnA -< (y, Just newstate)
|
||||||
|
|
||||||
hold :: Monad m => a -> MSF m (Maybe a) a
|
hold :: Monad m => a -> MSF m (Maybe a) a
|
||||||
hold =
|
hold =
|
||||||
mealy
|
mealy
|
||||||
|
|
Loading…
Reference in a new issue