"Toaster" notifications

To provide feedback to the user when a controller is plugged/unplugged.

4 files changed, 111 insertions, 33 deletions

diff --git a/src/Game.hs b/src/Game.hs
index c2f6083..d0092b6 100644
--- a/src/Game.hs
+++ b/src/Game.hs
@@ -12,6 +12,7 @@ import qualified Game.Hud as H
 import qualified Game.Map as M
 import qualified Game.Sprites as S
 import qualified Game.State as GS
+import qualified Game.Toaster as T
 import SDL (($=))
 import qualified SDL
 import qualified SDL.Image
@@ -45,8 +46,9 @@ data Env = Env
     font :: BF.BitmapFont,
     entities :: E.Entities,
     hud :: H.Hud,
+    toaster :: T.Toaster,
     state :: GS.State,
-    controls :: IORef C.Controls
+    controlsRef :: IORef C.Controls
   }
 
 defaultRenderRect :: SDL.Rectangle CInt
@@ -76,9 +78,10 @@ main = do
   map' <- M.load (head mapList) tsTexture
   sprites <- S.load "data/sprites.json" ssTexture
   font <- BF.load "data/font.json" bfTexture
-  controls <- newIORef C.init
-  entities <- E.mkEntities sprites map' controls
+  controlsRef <- newIORef C.init
+  entities <- E.mkEntities sprites map' controlsRef
   hud <- H.mkHud sprites font
+  toaster <- T.mkToaster font (fromIntegral gameHeight)
   gameLoop
     Env
       { window = window,
@@ -93,8 +96,9 @@ main = do
         font = font,
         entities = entities,
         hud = hud,
+        toaster = toaster,
         state = GS.initialState map',
-        controls = controls
+        controlsRef = controlsRef
       }
   SDL.destroyWindow window
   SDL.quit
@@ -133,22 +137,30 @@ gameLoop e = do
   let renderer = env.renderer
       canvas = env.canvas
       renderRect = env.renderRect
-      controls = env.controls
+      controlsRef = env.controlsRef
       state = env.state
 
   -- ESC or close the window to quit
   let quit = fromMaybe False (C.isPressed SDL.KeycodeEscape events) || SDL.QuitEvent `elem` events
   unless quit $ do
     -- update controls
-    writeIORef controls =<< (`C.update` events) =<< readIORef controls
+    updatedToasterEnv <- do
+      ctl <- readIORef controlsRef
+      C.update ctl env.toaster events
+        >>= ( \(ctl', toaster) -> do
+                writeIORef controlsRef ctl'
+                pure env {toaster = T.update toaster}
+            )
 
     SDL.rendererRenderTarget renderer $= Just canvas
     SDL.clear renderer
 
     updatedEnv <-
       if state.gameOverDelay /= 1
-        then playLoop =<< updateState env
-        else gameOverLoop env
+        then playLoop =<< updateState updatedToasterEnv
+        else gameOverLoop updatedToasterEnv
+
+    T.render renderer updatedEnv.toaster
 
     SDL.rendererRenderTarget renderer $= Nothing
     SDL.clear renderer
@@ -167,7 +179,7 @@ gameLoop e = do
           pure env {entities = es, state = state {GS.exit = True}}
       | state.levelCompleted == GS.ExitDone = do
           map' <- M.load (env.mapList !! (env.state.currentLevel + 1)) env.tsTexture
-          entities <- E.mkEntities env.sprites map' env.controls
+          entities <- E.mkEntities env.sprites map' env.controlsRef
           pure $
             env
               { map = map',
@@ -211,14 +223,14 @@ gameOverLoop e = do
       hud = e.hud
       font = e.font
       map' = e.map
-      controls = e.controls
+      controlsRef = e.controlsRef
 
-  ctl <- readIORef controls
+  ctl <- readIORef controlsRef
 
   if ctl.a
     then do
       -- retry last level
-      entities <- E.mkEntities sprites map' controls
+      entities <- E.mkEntities sprites map' controlsRef
       pure
         e {state = (GS.levelState e.state map') {GS.lives = GS.maxLives}, entities = entities}
     else do
diff --git a/src/Game/BitmapFont.hs b/src/Game/BitmapFont.hs
index d42f293..e68ee26 100644
--- a/src/Game/BitmapFont.hs
+++ b/src/Game/BitmapFont.hs
@@ -1,4 +1,4 @@
-module Game.BitmapFont (BitmapFont, load, renderText) where
+module Game.BitmapFont (BitmapFont, load, renderText, renderTextSolid) where
 
 import Control.Monad
 import Data.Map (Map)
@@ -36,7 +36,7 @@ load filename tex = do
     Ok desc -> pure $ BitmapFont desc tex
     Error e -> error e
 
--- | Render a string at position x, y using the prodided bitmap font.
+-- | Render a string at position x, y using the provided bitmap font.
 renderText :: SDL.Renderer -> BitmapFont -> Int -> Int -> String -> IO ()
 renderText renderer (BitmapFont (FontDesc w h m) tex) x y text = mapM_ renderOne (zip [0 ..] text)
   where
@@ -47,3 +47,10 @@ renderText renderer (BitmapFont (FontDesc w h m) tex) x y text = mapM_ renderOne
         -- find the glyph or render the special one as error
         src = fromMaybe (U.rect (length m * w) 0 w h) (Map.lookup c m)
         dst = U.rect (x + i * w) y w h
+
+-- | Render a string like renderText but with a translucid background.
+renderTextSolid :: SDL.Renderer -> BitmapFont -> Int -> Int -> String -> IO ()
+renderTextSolid renderer font@(BitmapFont (FontDesc w h _) _) x y text = do
+  -- TODO: make the rect transparent
+  _ <- SDL.fillRect renderer (Just (U.rect (x - 5) (y - 5) (length text * w + 10) (h + 10)))
+  renderText renderer font x y text
diff --git a/src/Game/Controller.hs b/src/Game/Controller.hs
index d47963e..4d0ba81 100644
--- a/src/Game/Controller.hs
+++ b/src/Game/Controller.hs
@@ -4,6 +4,7 @@ import Control.Monad
 import Data.Int (Int32)
 import Data.Maybe (fromMaybe, isNothing)
 import Foreign.C (peekCAString)
+import qualified Game.Toaster as T
 import qualified SDL
 import qualified SDL.Input.GameController as SDL
 import qualified SDL.Raw
@@ -22,28 +23,27 @@ data Controls = Controls
   }
   deriving (Show)
 
-processControllerEvents :: Controls -> [SDL.EventPayload] -> IO Controls
-processControllerEvents controls (SDL.ControllerDeviceEvent (SDL.ControllerDeviceEventData SDL.ControllerDeviceAdded joyIndex) : t) = do
+processControllerEvents :: Controls -> T.Toaster -> [SDL.EventPayload] -> IO (Controls, T.Toaster)
+processControllerEvents controls toaster (SDL.ControllerDeviceEvent (SDL.ControllerDeviceEventData SDL.ControllerDeviceAdded joyIndex) : t) = do
   if isNothing controls.joyId
     then do
       joyName <- peekCAString =<< SDL.Raw.gameControllerNameForIndex (fromIntegral joyIndex)
-      putStrLn $ "Connected gamepad: " ++ show joyName
+      let toaster' = T.add toaster $ "Connected " ++ show joyName
       gc <- SDL.Raw.gameControllerOpen (fromIntegral joyIndex)
       joy <- SDL.Raw.gameControllerGetJoystick gc
       joyId <- SDL.Raw.joystickInstanceID joy
-      processControllerEvents controls {joyId = Just joyId, gc = Just gc} t
-    else processControllerEvents controls t
-processControllerEvents controls (SDL.ControllerDeviceEvent (SDL.ControllerDeviceEventData SDL.ControllerDeviceRemoved joyId) : t) = do
-  c <-
+      processControllerEvents controls {joyId = Just joyId, gc = Just gc} toaster' t
+    else processControllerEvents controls toaster t
+processControllerEvents controls toaster (SDL.ControllerDeviceEvent (SDL.ControllerDeviceEventData SDL.ControllerDeviceRemoved joyId) : t) = do
+  (c, toaster') <-
     if Just joyId == controls.joyId
       then do
         forM_ (controls.gc) SDL.Raw.gameControllerClose
-        putStrLn "Disconnected gamepad"
-        pure controls {joyId = Nothing, gc = Nothing}
-      else pure controls
-  processControllerEvents c t
-processControllerEvents controls (_ : t) = processControllerEvents controls t
-processControllerEvents controls [] = pure controls
+        pure (controls {joyId = Nothing, gc = Nothing}, T.add toaster "Gamepad disconnected")
+      else pure (controls, toaster)
+  processControllerEvents c toaster' t
+processControllerEvents controls toaster (_ : t) = processControllerEvents controls toaster t
+processControllerEvents controls toaster [] = pure (controls, toaster)
 
 init :: Controls
 init = Controls False False False False False False False Nothing Nothing
@@ -78,12 +78,15 @@ updateKeyboard controls events =
       menu = fromMaybe False $ isPressed SDL.KeycodeReturn events
     }
 
-update :: Controls -> [SDL.EventPayload] -> IO Controls
-update controls events = do
-  updated <- processControllerEvents controls events
-  pure $ case updated.joyId of
-    Just _ -> updateGamepad updated events
-    _ -> updateKeyboard updated events
+update :: Controls -> T.Toaster -> [SDL.EventPayload] -> IO (Controls, T.Toaster)
+update controls toaster events = do
+  (updated, toaster') <- processControllerEvents controls toaster events
+  pure
+    ( case updated.joyId of
+        Just _ -> updateGamepad updated events
+        _ -> updateKeyboard updated events,
+      toaster'
+    )
 
 isPressed :: SDL.Keycode -> [SDL.EventPayload] -> Maybe Bool
 isPressed code events
diff --git a/src/Game/Toaster.hs b/src/Game/Toaster.hs
new file mode 100644
index 0000000..e3fbc69
--- /dev/null
+++ b/src/Game/Toaster.hs
@@ -0,0 +1,56 @@
+module Game.Toaster
+  ( Toaster,
+    mkToaster,
+    add,
+    update,
+    render,
+  )
+where
+
+import qualified Game.BitmapFont as BM
+import qualified SDL
+
+toastDelay :: Int
+toastDelay = 128
+
+data Toast = Toast
+  { message :: String,
+    y :: Int,
+    delay :: Int
+  }
+
+data Toaster = Toaster
+  { font :: BM.BitmapFont,
+    gameHeight :: Int,
+    queue :: [String],
+    current :: Maybe Toast
+  }
+
+mkToaster :: BM.BitmapFont -> Int -> IO Toaster
+mkToaster font height = do
+  pure $ Toaster font height [] Nothing
+
+add :: Toaster -> String -> Toaster
+add t message =
+  t {queue = t.queue ++ [message]}
+
+update :: Toaster -> Toaster
+update t = case t.current of
+  Nothing -> case t.queue of
+    [] -> t
+    (next : _) -> t {current = Just $ Toast next t.gameHeight toastDelay, queue = tail t.queue}
+  -- FIXME: magic number
+  Just toast -> t {current = updateToast (t.gameHeight - 14) toast}
+  where
+    updateToast :: Int -> Toast -> Maybe Toast
+    updateToast height toast
+      | toast.y > height && toast.delay > 0 = Just $ toast {y = toast.y - 1}
+      | toast.delay > 0 = Just $ toast {delay = toast.delay - 1}
+      | toast.y < t.gameHeight = Just $ toast {y = toast.y + 1}
+      | otherwise = Nothing
+
+render :: SDL.Renderer -> Toaster -> IO ()
+render renderer t = case t.current of
+  Nothing -> pure ()
+  Just toast -> do
+    BM.renderTextSolid renderer t.font 4 toast.y toast.message