aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Chelleport.hs112
-rw-r--r--src/Chelleport/AppShell.hs65
-rw-r--r--src/Chelleport/Draw.hs25
3 files changed, 113 insertions, 89 deletions
diff --git a/src/Chelleport.hs b/src/Chelleport.hs
index 536bba9..9511ff5 100644
--- a/src/Chelleport.hs
+++ b/src/Chelleport.hs
@@ -1,108 +1,42 @@
module Chelleport where
-import Control.Monad (foldM, unless)
-import Data.Maybe (fromMaybe)
-import Data.Text (Text)
+import Chelleport.AppShell (Action (AppAction, SysQuit), DrawContext, setupAppShell)
+import Chelleport.Draw (renderText)
import qualified Data.Text as Text
-import Foreign (Ptr)
-import Foreign.C (CInt)
-import SDL (($=))
import qualified SDL
-import qualified SDL.Font as TTF
-import System.Exit (exitSuccess)
-open :: IO ()
-open = do
- -- Initialize SDL
- SDL.initializeAll
- TTF.initialize
-
- -- Create window
- window <-
- SDL.createWindow
- "My SDL Application"
- ( SDL.defaultWindow
- { -- SDL.windowMode = SDL.Fullscreen,
- SDL.windowInputGrabbed = True,
- SDL.windowBorder = False
- }
- )
-
- 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
-
- appLoop renderer initState font
-
- SDL.destroyRenderer renderer
- SDL.destroyWindow window
- pure ()
-
-data State = State
- { stateExit :: Bool,
- stateCount :: Int
+newtype State = State
+ { stateCount :: Int
}
-data Action = ActionQuit | ActionUpdateCount Int
+newtype AppAction = ActionUpdateCount Int
-initState :: State
-initState = State {stateExit = False, stateCount = 0}
-
-appLoop :: SDL.Renderer -> State -> TTF.Font -> IO ()
-appLoop renderer state font = do
- events <- SDL.pollEvents
-
- SDL.clear renderer
- renderText renderer font $ Text.pack ("Hello, Haskell: " ++ show (stateCount state))
- SDL.present renderer
+open :: IO ()
+open = setupAppShell initialState update eventToAction render
- newState <- evaluateEvents state events
- unless (stateExit newState) (appLoop renderer newState font)
+initialState :: State
+initialState = State {stateCount = 0}
-evaluateEvents :: State -> [SDL.Event] -> IO State
-evaluateEvents = foldM evaluate
- where
- evaluate :: State -> SDL.Event -> IO State
- evaluate st event = maybe (pure st) (update st) (eventToAction event)
+render :: State -> DrawContext -> IO ()
+render state ctx = do
+ renderText ctx $ Text.pack $ "Hello" ++ show (stateCount state)
-update :: State -> Action -> IO State
-update state ActionQuit = pure state {stateExit = True}
-update state (ActionUpdateCount count) = pure state {stateCount = stateCount state + count}
+update :: State -> DrawContext -> AppAction -> IO State
+update state _ctx (ActionUpdateCount count) = do
+ -- SDL.warpMouse SDL.WarpGlobal $ SDL.P $ SDL.V2 (unsafeCoerce $ 10 * stateCount state) 100
+ pure state {stateCount = count}
-eventToAction :: SDL.Event -> Maybe Action
-eventToAction event =
+eventToAction :: State -> SDL.Event -> Maybe (Action AppAction)
+eventToAction state event =
case SDL.eventPayload event of
- SDL.KeyboardEvent keyboardEvent
- | isKeyPress keyboardEvent SDL.KeycodeQ -> Just ActionQuit
- SDL.KeyboardEvent keyboardEvent
- | isKeyPress keyboardEvent SDL.KeycodeJ -> Just $ ActionUpdateCount (-1)
- SDL.KeyboardEvent keyboardEvent
- | isKeyPress keyboardEvent SDL.KeycodeK -> Just $ ActionUpdateCount 1
+ SDL.KeyboardEvent ev
+ | isKeyPress ev SDL.KeycodeQ -> Just SysQuit
+ | isKeyPress ev SDL.KeycodeEscape -> Just SysQuit
+ | isKeyPress ev SDL.KeycodeJ -> Just $ AppAction $ ActionUpdateCount (stateCount state - 1)
+ | isKeyPress ev SDL.KeycodeK -> Just $ AppAction $ ActionUpdateCount (stateCount state + 1)
_ -> Nothing
isKeyPress :: SDL.KeyboardEventData -> SDL.Keycode -> Bool
isKeyPress keyboardEvent keyCode =
SDL.keyboardEventKeyMotion keyboardEvent == SDL.Pressed
&& SDL.keysymKeycode (SDL.keyboardEventKeysym keyboardEvent) == keyCode
-
--- Render text to the screen
-renderText :: SDL.Renderer -> TTF.Font -> Text -> IO ()
-renderText renderer font text = do
- -- Render text in white
- surface <- TTF.blended font (SDL.V4 255 255 255 255) text
- texture <- SDL.createTextureFromSurface renderer 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 renderer texture Nothing (Just (SDL.Rectangle position (SDL.V2 textWidth textHeight)))
- SDL.destroyTexture texture
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