Add true randomness

Previously, randomness was faked via bad pseudo-randomness code, so
let's refactor some of this to add true randomness support.

snake.cabal

@@ -12,5 +12,7 @@ executable snake
   default-language:   GHC2021
   default-extensions: Arrows
   build-depends: base,
+                 mtl,
+                 random,
                  dunai,
                  gloss

src/Game/Engine.hs

@@ -1,10 +1,10 @@
 {-# LANGUAGE Arrows #-}
 {-# LANGUAGE OverloadedRecordDot #-}
-{-# LANGUAGE RecordWildCards #-}
 
 module Game.Engine where
 
 import Control.Monad (guard)
+import Control.Monad.Trans
 import Control.Monad.Trans.MSF.Maybe
 import Control.Monad.Trans.MSF.Reader
 import Control.Monad.Trans.MSF.Writer
@@ -43,7 +43,7 @@ handleEvents = mapMaybe getDir <$> getKeys
 
 -- * Core game engine
 
-tickState :: Maybe Direction -> GameState -> Maybe GameState
+tickState :: Maybe Direction -> GameState -> MaybeT IO GameState
 tickState dir state =
   let moveDir = setDir state.moveDir dir
       newBlock = movePos moveDir $ head state.snakePos
@@ -56,19 +56,16 @@ tickState dir state =
       isHit = head snakePos `notElem` tail snakePos
       berryPos =
         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)
 
-gameSF :: Monad m => MSF (MaybeT (DrawerT m)) () GameState
+gameSF :: MonadIO m => MSF (MaybeT (DrawerT m)) () GameState
 gameSF = proc () -> do
   -- A "tick" is each frame that the snake advances
   n <- count -< ()
@@ -81,7 +78,7 @@ gameSF = proc () -> do
   -- only run `tick` whenever there's a tick
   pauseMSF undefined tick -< (dir, isTick)
 
-mainSF :: Monad m => MSF (DrawerT m) () ()
+mainSF :: MonadIO m => MSF (DrawerT m) () ()
 mainSF = proc () -> do
   keys <- getKeys -< ()
   let esc = SpecialKey KeyEsc `elem` keys

src/Game/State.hs

@@ -1,6 +1,11 @@
+{-# LANGUAGE LambdaCase #-}
+
 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 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 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 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
   { snakePos :: [(Int, Int)],
@@ -25,5 +29,21 @@ data GameState = GameState
     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

src/Game/Utils.hs

@@ -52,6 +52,12 @@ draw = arrM tell
 
 -- * 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 =
   mealy