aztecs-sdl 0.5.0 → 0.6.0
raw patch · 2 files changed
+229/−193 lines, 2 filesdep ~aztecs
Dependency ranges changed: aztecs
Files
- aztecs-sdl.cabal +2/−2
- src/Aztecs/SDL.hs +227/−191
aztecs-sdl.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: aztecs-sdl-version: 0.5.0+version: 0.6.0 license: BSD-3-Clause license-file: LICENSE maintainer: matt@hunzinger.me@@ -27,7 +27,7 @@ ghc-options: -Wall build-depends: base >=4.6 && <5,- aztecs >= 0.8 && <0.9,+ aztecs >= 0.9 && <0.10, containers >=0.6, deepseq >=1, mtl >=2,
src/Aztecs/SDL.hs view
@@ -1,10 +1,17 @@ {-# LANGUAGE Arrows #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeApplications #-} +-- |+-- Module : Aztecs.SDL+-- Copyright : (c) Matt Hunzinger, 2025+-- License : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer : matt@hunzinger.me+-- Stability : provisional+-- Portability : non-portable (GHC extensions) module Aztecs.SDL ( -- * Window components WindowRenderer (..),@@ -45,140 +52,149 @@ where import Aztecs-import Aztecs.Camera (addCameraTargets)+import Aztecs.Camera import qualified Aztecs.ECS.Access as A import qualified Aztecs.ECS.Query as Q import qualified Aztecs.ECS.System as S import Aztecs.Input- ( InputMotion (..),- MouseButton (..),- handleKeyboardEvent,- keyboardInput,- mouseInput,- )-import Control.Arrow (Arrow (..), returnA, (>>>))+import Control.Arrow import Control.DeepSeq+import Control.Monad import Control.Monad.IO.Class+import Data.Foldable import qualified Data.Map.Strict as Map-import Data.Maybe (fromMaybe, mapMaybe)+import Data.Maybe import qualified Data.Text as T-import GHC.Generics (Generic)+import GHC.Generics import SDL hiding (InputMotion (..), MouseButton (..), Surface, Texture, Window, windowTitle) import qualified SDL -#if !MIN_VERSION_base(4,20,0)-import Data.Foldable (foldl')-#endif- -- | Window renderer component.+--+-- @since 0.5 data WindowRenderer = WindowRenderer { -- | SDL window.+ --+ -- @since 0.5 windowRendererRaw :: !SDL.Window, -- | SDL renderer.+ --+ -- @since 0.5 windowRenderer :: !Renderer } deriving (Show, Generic) +-- | @since 0.5 instance Component WindowRenderer +-- | @since 0.5 instance NFData WindowRenderer where rnf = rwhnf -- | Setup SDL-setup :: (MonadIO m) => (ArrowAccessSchedule b m arr) => arr () ()-setup =- access (const $ liftIO initializeAll)- >>> access- ( const $ do- A.spawn_ . bundle $ Time 0- A.spawn_ $ bundle keyboardInput- A.spawn_ $ bundle mouseInput- )+--+-- @since 0.5+setup :: (MonadAccess b m, MonadIO m) => m ()+setup = do+ liftIO initializeAll+ A.spawn_ . bundle $ Time 0+ A.spawn_ $ bundle keyboardInput+ A.spawn_ $ bundle mouseInput -- | Update SDL windows+--+-- @since 0.5 update :: ( ArrowQueryReader qr, ArrowDynamicQueryReader qr,- ArrowReaderSystem qr rs,- ArrowQueueSystem b qm rs,- ArrowReaderSchedule rs arr,- ArrowQuery q,- ArrowSystem q s,- ArrowReaderSystem qr s,- ArrowQueueSystem b qm s,- ArrowSchedule s arr,- MonadIO m,- ArrowAccessSchedule b m arr+ ArrowQuery m q,+ MonadSystem q s,+ MonadReaderSystem qr s,+ MonadIO s,+ MonadAccess b s,+ MonadIO m ) =>- arr () ()-update =+ s ()+update = do updateTime- >>> addWindows- >>> reader (addCameraTargets >>> addSurfaceTargets)- >>> buildTextures- >>> handleInput+ join addWindows+ join addCameraTargets+ join addSurfaceTargets+ join buildTextures+ handleInput -- | Setup new windows.+--+-- @since 0.5 addWindows :: ( ArrowQueryReader q, ArrowDynamicQueryReader q,- ArrowReaderSystem q s,- ArrowQueueSystem b qm s,- ArrowReaderSchedule s arr,- MonadIO m,- ArrowAccessSchedule b m arr+ MonadReaderSystem q s,+ MonadIO s,+ MonadAccess b ma ) =>- arr () ()-addWindows = proc () -> do- newWindows <- reader $ S.filter (Q.entity &&& Q.fetch @_ @Window) (without @WindowRenderer) -< ()- newWindows' <- access $ liftIO . mapM createWindowRenderer -< newWindows- reader $ S.queue $ mapM_ insertWindowRenderer -< newWindows'+ s (ma ())+addWindows = do+ newWindows <- S.filter () (Q.entity &&& Q.fetch @_ @Window) (without @WindowRenderer)+ newWindows' <- liftIO $ mapM createWindowRenderer newWindows+ return $ mapM_ insertWindowRenderer newWindows' where createWindowRenderer (eId, window) = do sdlWindow <- createWindow (T.pack $ windowTitle window) defaultWindow renderer <- createRenderer sdlWindow (-1) defaultRenderer return (eId, sdlWindow, renderer)- insertWindowRenderer (eId, window, renderer) = A.insert eId (WindowRenderer window renderer)+ insertWindowRenderer (eId, window, renderer) = A.insert eId . bundle $ WindowRenderer window renderer -- | Surface texture component.+--+-- @since 0.5 newtype SurfaceTexture = SurfaceTexture { -- | SDL texture.+ --+ -- @since 0.5 unSurfaceTexture :: SDL.Texture } deriving (Generic) +-- | @since 0.5 instance Component SurfaceTexture +-- | @since 0.5 instance NFData SurfaceTexture where rnf = rwhnf +-- | Query all window textures.+--+-- @since 0.5 allWindowTextures ::- (ArrowQueryReader q, ArrowDynamicQueryReader q, ArrowReaderSystem q arr) =>- arr () [(WindowRenderer, [(EntityID, Surface, Transform2D, Maybe SurfaceTexture)])]+ (ArrowQueryReader q, ArrowDynamicQueryReader q, MonadReaderSystem q s) =>+ s [(WindowRenderer, [(EntityID, Surface, Transform2D, Maybe SurfaceTexture)])] allWindowTextures =- allWindowDraws- (arr (const ()))- ( proc () -> do- e <- Q.entity -< ()- surface <- Q.fetch -< ()- transform <- Q.fetch -< ()- texture <- Q.fetchMaybe -< ()- returnA -< (e, surface, transform, texture)- )- >>> arr (\cs -> map (\(w, cs') -> (w, concatMap snd cs')) cs)+ map (second (concatMap snd))+ <$> allWindowDraws+ (arr (const ()))+ ( proc () -> do+ e <- Q.entity -< ()+ surface <- Q.fetch -< ()+ transform <- Q.fetch -< ()+ texture <- Q.fetchMaybe -< ()+ returnA -< (e, surface, transform, texture)+ ) -- | Build textures from surfaces in preparation for `drawTextures`.+--+-- @since 0.5 buildTextures :: ( ArrowQueryReader q, ArrowDynamicQueryReader q,- ArrowReaderSystem q s,- ArrowReaderSchedule s arr,- MonadIO m,- ArrowAccessSchedule b m arr+ MonadReaderSystem q s,+ MonadAccess b m,+ MonadIO m ) =>- arr () ()-buildTextures =- let go windowDraws =+ s (m ())+buildTextures = do+ windowTextures <- allWindowTextures+ let go = mapM_ ( \(window, cameraDraws) -> do let renderer = windowRenderer window@@ -189,77 +205,70 @@ case maybeTexture of Just (SurfaceTexture lastTexture) -> destroyTexture lastTexture Nothing -> return ()- A.insert eId (SurfaceTexture sdlTexture)+ A.insert eId . bundle $ SurfaceTexture sdlTexture A.insert eId- ( Size $+ ( bundle . Size $ transformScale transform- * fromMaybe- (fmap fromIntegral $ V2 (textureWidth textureDesc) (textureHeight textureDesc))- ((fmap (\(Rectangle _ s) -> fmap fromIntegral s) $ surfaceBounds surface))+ * maybe (fromIntegral <$> V2 (textureWidth textureDesc) (textureHeight textureDesc)) (\(Rectangle _ s) -> fmap fromIntegral s) (surfaceBounds surface) ) ) cameraDraws )- windowDraws- in reader allWindowTextures >>> access go+ windowTextures+ return go -draw ::- ( ArrowQueryReader q,- ArrowDynamicQueryReader q,- ArrowReaderSystem q s,- ArrowReaderSchedule s arr,- MonadIO m,- ArrowAccessSchedule b m arr- ) =>- arr () ()-draw =- let go windowDraws =+-- | Draw all textures to their targetted windows.+--+-- @since 0.5+draw :: (ArrowQueryReader q, ArrowDynamicQueryReader q, MonadReaderSystem q s, MonadIO s) => s ()+draw = do+ cameraSurfaces <- allCameraSurfaces+ mapM_+ ( \(window, cameraDraws) -> do+ let renderer = windowRenderer window+ clear renderer mapM_- ( \(window, cameraDraws) -> do- let renderer = windowRenderer window- rendererDrawColor renderer $= V4 0 0 0 255- clear renderer+ ( \((camera, cameraTransform), cameraDraws') -> do+ rendererScale renderer $= fmap realToFrac (cameraScale camera)+ rendererViewport renderer+ $= Just+ ( Rectangle+ (P (fromIntegral <$> transformTranslation cameraTransform))+ (fromIntegral <$> cameraViewport camera)+ ) mapM_- ( \((camera, cameraTransform), cameraDraws') -> do- rendererScale renderer $= fmap realToFrac (cameraScale camera)- rendererViewport renderer- $= Just- ( Rectangle- (P (fmap fromIntegral $ transformTranslation cameraTransform))- (fmap fromIntegral $ cameraViewport camera)- )- mapM_- ( \(surface, transform, texture) -> do- textureDesc <- queryTexture $ unSurfaceTexture texture- copyEx- renderer- (unSurfaceTexture texture)- (fmap fromIntegral <$> surfaceBounds surface)- ( Just- ( Rectangle- (fmap fromIntegral . P $ transformTranslation transform)- ( fromMaybe- (fmap fromIntegral $ V2 (textureWidth textureDesc) (textureHeight textureDesc))- ((fmap (\(Rectangle _ s) -> fmap fromIntegral s) $ surfaceBounds surface))- )- )- )- (realToFrac $ transformRotation transform)- Nothing- (V2 False False)+ ( \(surface, transform, texture) -> do+ textureDesc <- queryTexture $ unSurfaceTexture texture+ copyEx+ renderer+ (unSurfaceTexture texture)+ (fmap fromIntegral <$> surfaceBounds surface)+ ( Just+ ( Rectangle+ (fmap fromIntegral . P $ transformTranslation transform)+ ( maybe (fromIntegral <$> V2 (textureWidth textureDesc) (textureHeight textureDesc)) (\(Rectangle _ s) -> fmap fromIntegral s) (surfaceBounds surface)+ )+ ) )- cameraDraws'+ (realToFrac $ transformRotation transform)+ Nothing+ (V2 False False) )- cameraDraws- present renderer+ cameraDraws' )- windowDraws- in reader allCameraSurfaces >>> access go+ cameraDraws+ rendererDrawColor renderer $= V4 0 0 0 255+ present renderer+ )+ cameraSurfaces +-- | Query all cameras and their target surfaces.+--+-- @since 0.5 allCameraSurfaces ::- (ArrowQueryReader q, ArrowDynamicQueryReader q, ArrowReaderSystem q arr) =>- arr () [(WindowRenderer, [((Camera, Transform2D), [(Surface, Transform2D, SurfaceTexture)])])]+ (ArrowQueryReader q, ArrowDynamicQueryReader q, MonadReaderSystem q s) =>+ s [(WindowRenderer, [((Camera, Transform2D), [(Surface, Transform2D, SurfaceTexture)])])] allCameraSurfaces = allWindowDraws (Q.fetch &&& Q.fetch)@@ -270,32 +279,34 @@ returnA -< (surface, transform, texture) ) +-- | Query all windows and drawable surfaces.+--+-- @since 0.5 allWindowDraws ::- (ArrowQueryReader q, ArrowDynamicQueryReader q, ArrowReaderSystem q arr) =>- (q () a) ->- (q () b) ->- arr () [(WindowRenderer, [(a, [b])])]-allWindowDraws qA qB = proc () -> do+ (ArrowQueryReader q, ArrowDynamicQueryReader q, MonadReaderSystem q s) =>+ q () a ->+ q () b ->+ s [(WindowRenderer, [(a, [b])])]+allWindowDraws qA qB = do cameras <- S.all+ () ( proc () -> do eId <- Q.entity -< () cameraTarget <- Q.fetch @_ @CameraTarget -< () a <- qA -< () returnA -< (eId, cameraTarget, a) )- -<- ()- windows <- S.all (Q.entity &&& Q.fetch @_ @WindowRenderer) -< ()++ windows <- S.all () (Q.entity &&& Q.fetch @_ @WindowRenderer) draws <- S.all+ () ( proc () -> do t <- Q.fetch @_ @SurfaceTarget -< () a <- qB -< () returnA -< (t, a) )- -<- () let cameraDraws = map ( \(eId, cameraTarget, b) ->@@ -320,10 +331,12 @@ ) ) windows- returnA -< windowDraws+ return windowDraws -- | Surface target component. -- This component can be used to specify which `Camera` to draw a `Surface` to.+--+-- @since 0.5 newtype SurfaceTarget = SurfaceTarget {drawTargetCamera :: EntityID} deriving (Eq, Show, Generic, NFData) @@ -331,99 +344,107 @@ -- | Surface component. -- This component can be used to draw to a window.+--+-- @since 0.5 data Surface = Surface { sdlSurface :: !SDL.Surface, surfaceBounds :: !(Maybe (Rectangle Int)) } +-- | @since 0.5 instance Component Surface +-- | @since 0.5 instance NFData Surface where rnf = rwhnf -- | Add `SurfaceTarget` components to entities with a new `Surface` component.+--+-- @since 0.5 addSurfaceTargets :: ( ArrowQueryReader q, ArrowDynamicQueryReader q,- ArrowReaderSystem q arr,- ArrowQueueSystem b m arr+ MonadReaderSystem q s,+ MonadAccess b m ) =>- arr () ()-addSurfaceTargets = proc () -> do- cameras <- S.all (Q.entity &&& Q.fetch @_ @Camera) -< ()- newDraws <- S.filter (Q.entity &&& Q.fetch @_ @Surface) (without @SurfaceTarget) -< ()- S.queue- ( \(newDraws, cameras) -> case cameras of- (cameraEId, _) : _ -> mapM_ (\(eId, _) -> A.insert eId $ SurfaceTarget cameraEId) newDraws+ s (m ())+addSurfaceTargets = do+ cameras <- S.all () (Q.entity &&& Q.fetch @_ @Camera)+ newDraws <- S.filter () (Q.entity &&& Q.fetch @_ @Surface) (without @SurfaceTarget)+ let go = case cameras of+ (cameraEId, _) : _ -> mapM_ (\(eId, _) -> A.insert eId . bundle $ SurfaceTarget cameraEId) newDraws _ -> return ()- )- -<- (newDraws, cameras)+ return go +-- | Update the current `Time`.+--+-- @since 0.5 updateTime ::- ( ArrowQuery q,- ArrowSystem q s,- ArrowSchedule s arr,- MonadIO m,- ArrowAccessSchedule b m arr+ ( ArrowQuery m q,+ MonadSystem q s,+ MonadIO m ) =>- arr () ()-updateTime = proc () -> do- t <- access . const $ liftIO SDL.ticks -< ()- system $ S.mapSingle Q.set -< Time t- returnA -< ()+ s ()+updateTime = void . S.mapSingle () $ Q.adjustM (\_ _ -> Time <$> SDL.ticks) +-- | Keyboard input system.+--+-- @since 0.5 handleInput :: ( ArrowQueryReader qr,- ArrowReaderSystem qr s,- ArrowQuery q,- ArrowSystem q s,- ArrowSchedule s arr,- MonadIO m,- ArrowAccessSchedule b m arr+ MonadReaderSystem qr s,+ ArrowQuery m q,+ MonadSystem q s,+ MonadIO s ) =>- arr () ()-handleInput = access (const pollEvents) >>> system handleInput'+ s ()+handleInput = liftIO pollEvents >>= handleInput' -- | Keyboard input system.+--+-- @since 0.5 handleInput' ::- (ArrowQueryReader qr, ArrowReaderSystem qr arr, ArrowQuery q, ArrowSystem q arr) =>- arr [Event] ()-handleInput' = proc events -> do- kb <- S.single Q.fetch -< ()- mouse <- S.single Q.fetch -< ()+ (ArrowQueryReader qr, MonadReaderSystem qr s, ArrowQuery m q, MonadSystem q s) =>+ [Event] ->+ s ()+handleInput' events = do let go (kbAcc, mouseAcc) event = case eventPayload event of KeyboardEvent keyboardEvent -> ( case fromSDLKeycode $ keysymKeycode $ keyboardEventKeysym keyboardEvent of- Just key -> handleKeyboardEvent key (motionFromSDL $ keyboardEventKeyMotion keyboardEvent) kbAcc+ Just key -> handleKeyboardEvent key (motionFromSDL $ keyboardEventKeyMotion keyboardEvent) . kbAcc Nothing -> kbAcc, mouseAcc ) MouseMotionEvent mouseMotionEvent -> ( kbAcc,- mouseAcc- { mousePosition = (fmap fromIntegral $ mouseMotionEventPos mouseMotionEvent),- mouseOffset = (fmap fromIntegral $ mouseMotionEventRelMotion mouseMotionEvent),- mouseButtons = (mouseButtons mouseAcc)- }+ \m ->+ (mouseAcc m)+ { mousePosition = fromIntegral <$> mouseMotionEventPos mouseMotionEvent,+ mouseOffset = fromIntegral <$> mouseMotionEventRelMotion mouseMotionEvent,+ mouseButtons = mouseButtons m+ } ) MouseButtonEvent mouseButtonEvent -> ( kbAcc,- mouseAcc- { mousePosition = (fmap fromIntegral $ mouseButtonEventPos mouseButtonEvent),- mouseButtons =- Map.insert- (mouseButtonFromSDL $ mouseButtonEventButton mouseButtonEvent)- (motionFromSDL $ mouseButtonEventMotion mouseButtonEvent)- (mouseButtons mouseAcc)- }+ \m ->+ (mouseAcc m)+ { mousePosition = fromIntegral <$> mouseButtonEventPos mouseButtonEvent,+ mouseButtons =+ Map.insert+ (mouseButtonFromSDL $ mouseButtonEventButton mouseButtonEvent)+ (motionFromSDL $ mouseButtonEventMotion mouseButtonEvent)+ (mouseButtons m)+ } ) _ -> (kbAcc, mouseAcc)- (kb', mouseInput') = foldl' go (kb {keyboardEvents = mempty}, mouse {mouseOffset = V2 0 0}) events- S.mapSingle Q.set -< kb'- S.mapSingle Q.set -< mouseInput'- returnA -< ()+ (updateKb, updateMouse) = foldl' go (id, id) events+ _ <- S.map () . Q.adjust $ const updateKb+ _ <- S.map () . Q.adjust $ const updateMouse+ return () +-- | Convert an SDL mouse button to `MouseButton`.+--+-- @since 0.5 mouseButtonFromSDL :: SDL.MouseButton -> MouseButton mouseButtonFromSDL b = case b of SDL.ButtonLeft -> ButtonLeft@@ -433,6 +454,9 @@ SDL.ButtonX2 -> ButtonX2 SDL.ButtonExtra i -> ButtonExtra i +-- | Convert a `MouseButton` to an SDL mouse button.+--+-- @since 0.5 mouseButtonToSDL :: MouseButton -> SDL.MouseButton mouseButtonToSDL b = case b of ButtonLeft -> SDL.ButtonLeft@@ -442,16 +466,25 @@ ButtonX2 -> SDL.ButtonX2 ButtonExtra i -> SDL.ButtonExtra i +-- | Convert an SDL input motion to `InputMotion`.+--+-- @since 0.5 motionFromSDL :: SDL.InputMotion -> InputMotion motionFromSDL m = case m of SDL.Pressed -> Pressed SDL.Released -> Released +-- | Convert an `InputMotion` to an SDL input motion.+--+-- @since 0.5 motionToSDL :: InputMotion -> SDL.InputMotion motionToSDL m = case m of Pressed -> SDL.Pressed Released -> SDL.Released +-- | Convert an SDL key code to `Key`.+--+-- @since 0.5 toSDLKeycode :: Key -> SDL.Keycode toSDLKeycode key = case key of KeyA -> SDL.KeycodeA@@ -547,9 +580,12 @@ KeyNumpadPlus -> SDL.KeycodeKPPlus KeyNumpadEnter -> SDL.KeycodeKPEnter KeyNumpadPeriod -> SDL.KeycodeKPPeriod- KeySuper -> SDL.KeycodeLGUI -- assuming left Super (Windows/Command key); SDL also has RGUI+ KeySuper -> SDL.KeycodeLGUI KeyMenu -> SDL.KeycodeMenu +-- | Convert a `Key` to an SDL key code.+--+-- @since 0.5 fromSDLKeycode :: SDL.Keycode -> Maybe Key fromSDLKeycode keycode = case keycode of SDL.KeycodeA -> Just KeyA