Refactor window drawing and app shell

2 files changed, 90 insertions, 0 deletions

diff --git a/src/Chelleport/AppShell.hs b/src/Chelleport/AppShell.hs
new file mode 100644
index 0000000..5f97877
--- /dev/null
+++ b/src/Chelleport/AppShell.hs
@@ -0,0 +1,65 @@
+module Chelleport.AppShell where
+
+import Control.Monad (foldM, unless)
+import SDL (($=))
+import qualified SDL
+import qualified SDL.Font as TTF
+
+data Action act = SysQuit | AppAction act
+
+newtype SysState = SysState {sysExit :: Bool}
+
+data DrawContext = DrawContext
+  { ctxWindow :: SDL.Window,
+    ctxRenderer :: SDL.Renderer,
+    ctxFont :: TTF.Font
+  }
+
+createContext :: IO DrawContext
+createContext = do
+  let windowCfg =
+        SDL.defaultWindow -- SDL.windowMode = SDL.Fullscreen,
+          { SDL.windowInputGrabbed = True,
+            SDL.windowBorder = False
+          }
+  window <- SDL.createWindow "My SDL Application" windowCfg
+  renderer <- SDL.createRenderer window (-1) SDL.defaultRenderer
+  font <- TTF.load "Inter-Regular.ttf" 16
+
+  SDL.windowOpacity window $= 0.6
+  SDL.rendererDrawBlendMode renderer $= SDL.BlendAlphaBlend
+  SDL.rendererDrawColor renderer $= SDL.V4 0 0 0 0
+
+  pure $ DrawContext {ctxWindow = window, ctxRenderer = renderer, ctxFont = font}
+
+setupAppShell ::
+  state ->
+  (state -> DrawContext -> appAction -> IO state) ->
+  (state -> SDL.Event -> Maybe (Action appAction)) ->
+  (state -> DrawContext -> IO ()) ->
+  IO ()
+setupAppShell initState update eventHandler draw = do
+  -- Initialize SDL
+  SDL.initializeAll
+  TTF.initialize
+
+  ctx <- createContext
+  appLoop ctx (initState, SysState {sysExit = False})
+
+  SDL.destroyRenderer $ ctxRenderer ctx
+  SDL.destroyWindow $ ctxWindow ctx
+  where
+    appLoop drawCtx (state, sysState) = do
+      events <- SDL.pollEvents
+
+      SDL.clear $ ctxRenderer drawCtx
+      draw state drawCtx
+      SDL.present $ ctxRenderer drawCtx
+
+      (newState, newSysState) <- foldM (evaluateEvent drawCtx) (state, sysState) events
+      unless (sysExit newSysState) $ appLoop drawCtx (newState, newSysState)
+
+    evaluateEvent drawCtx stTup event = maybe (pure stTup) (updateState drawCtx stTup) (eventHandler (fst stTup) event)
+
+    updateState _drawCtx (state, sysState) SysQuit = pure (state, sysState {sysExit = True})
+    updateState drawCtx (state, sysState) (AppAction action) = (,sysState) <$> update state drawCtx action
diff --git a/src/Chelleport/Draw.hs b/src/Chelleport/Draw.hs
new file mode 100644
index 0000000..c042e32
--- /dev/null
+++ b/src/Chelleport/Draw.hs
@@ -0,0 +1,25 @@
+module Chelleport.Draw where
+
+import Chelleport.AppShell (DrawContext (ctxFont, ctxRenderer))
+import Data.Text (Text)
+import qualified SDL
+import qualified SDL.Font as TTF
+
+-- Render text to the screen
+renderText :: DrawContext -> Text -> IO ()
+renderText ctx text = do
+  -- Render text in white
+  surface <- TTF.blended (ctxFont ctx) (SDL.V4 255 255 255 255) text
+  texture <- SDL.createTextureFromSurface (ctxRenderer ctx) surface
+  SDL.freeSurface surface
+
+  -- Get text dimensions
+  textureInfo <- SDL.queryTexture texture
+  let textWidth = SDL.textureWidth textureInfo
+      textHeight = SDL.textureHeight textureInfo
+      position =
+        SDL.P (SDL.V2 ((640 - textWidth) `div` 2) ((480 - textHeight) `div` 2))
+
+  -- Render the texture
+  SDL.copy (ctxRenderer ctx) texture Nothing $ Just (SDL.Rectangle position (SDL.V2 textWidth textHeight))
+  SDL.destroyTexture texture