aztecs-sdl 0.6.0 → 0.7.0
raw patch · 2 files changed
+129/−127 lines, 2 filesdep ~aztecsdep ~base
Dependency ranges changed: aztecs, base
Files
- aztecs-sdl.cabal +3/−3
- src/Aztecs/SDL.hs +126/−124
aztecs-sdl.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: aztecs-sdl-version: 0.6.0+version: 0.7.0 license: BSD-3-Clause license-file: LICENSE maintainer: matt@hunzinger.me@@ -26,8 +26,8 @@ default-language: Haskell2010 ghc-options: -Wall build-depends:- base >=4.6 && <5,- aztecs >= 0.9 && <0.10,+ base >=4 && <5,+ aztecs >= 0.10 && <0.11, containers >=0.6, deepseq >=1, mtl >=2,
src/Aztecs/SDL.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE Arrows #-}+{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -71,15 +71,15 @@ -- | Window renderer component. ----- @since 0.5+-- @since 0.6 data WindowRenderer = WindowRenderer { -- | SDL window. --- -- @since 0.5+ -- @since 0.6 windowRendererRaw :: !SDL.Window, -- | SDL renderer. --- -- @since 0.5+ -- @since 0.6 windowRenderer :: !Renderer } deriving (Show, Generic)@@ -93,7 +93,7 @@ -- | Setup SDL ----- @since 0.5+-- @since 0.6 setup :: (MonadAccess b m, MonadIO m) => m () setup = do liftIO initializeAll@@ -103,11 +103,13 @@ -- | Update SDL windows ----- @since 0.5+-- @since 0.6 update ::- ( ArrowQueryReader qr,- ArrowDynamicQueryReader qr,- ArrowQuery m q,+ ( Applicative qr,+ QueryReaderF qr,+ DynamicQueryReaderF qr,+ Applicative q,+ QueryF m q, MonadSystem q s, MonadReaderSystem qr s, MonadIO s,@@ -123,19 +125,65 @@ join buildTextures handleInput +-- | Draw all textures to their targetted windows.+--+-- @since 0.6+draw :: (Applicative q, QueryReaderF q, DynamicQueryReaderF q, MonadReaderSystem q s, MonadIO s) => s ()+draw = do+ cameraSurfaces <- allCameraSurfaces+ mapM_+ ( \(window, cameraDraws) -> do+ let renderer = windowRenderer window+ clear renderer+ mapM_+ ( \((camera, cameraTransform), cameraDraws') -> do+ rendererScale renderer $= fmap realToFrac (cameraScale camera)+ rendererViewport renderer+ $= Just+ ( Rectangle+ (P (fromIntegral <$> transformTranslation cameraTransform))+ (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)+ ( maybe (fromIntegral <$> V2 (textureWidth textureDesc) (textureHeight textureDesc)) (\(Rectangle _ s) -> fmap fromIntegral s) (surfaceBounds surface)+ )+ )+ )+ (realToFrac $ transformRotation transform)+ Nothing+ (V2 False False)+ )+ cameraDraws'+ )+ cameraDraws+ rendererDrawColor renderer $= V4 0 0 0 255+ present renderer+ )+ cameraSurfaces+ -- | Setup new windows. ----- @since 0.5+-- @since 0.6 addWindows ::- ( ArrowQueryReader q,- ArrowDynamicQueryReader q,+ ( Applicative q,+ QueryReaderF q,+ DynamicQueryReaderF q, MonadReaderSystem q s, MonadIO s, MonadAccess b ma ) => s (ma ()) addWindows = do- newWindows <- S.filter () (Q.entity &&& Q.fetch @_ @Window) (without @WindowRenderer)+ newWindows <- S.filter ((,) <$> Q.entity <*> Q.fetch @_ @Window) (without @WindowRenderer) newWindows' <- liftIO $ mapM createWindowRenderer newWindows return $ mapM_ insertWindowRenderer newWindows' where@@ -147,11 +195,11 @@ -- | Surface texture component. ----- @since 0.5+-- @since 0.6 newtype SurfaceTexture = SurfaceTexture { -- | SDL texture. --- -- @since 0.5+ -- @since 0.6 unSurfaceTexture :: SDL.Texture } deriving (Generic)@@ -165,28 +213,29 @@ -- | Query all window textures. ----- @since 0.5+-- @since 0.6 allWindowTextures ::- (ArrowQueryReader q, ArrowDynamicQueryReader q, MonadReaderSystem q s) =>+ (Applicative q, QueryReaderF q, DynamicQueryReaderF q, MonadReaderSystem q s) => s [(WindowRenderer, [(EntityID, Surface, Transform2D, Maybe SurfaceTexture)])] allWindowTextures = 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)+ (pure ())+ ( do+ e <- Q.entity+ surface <- Q.fetch+ transform <- Q.fetch+ texture <- Q.fetchMaybe+ return (e, surface, transform, texture) ) -- | Build textures from surfaces in preparation for `drawTextures`. ----- @since 0.5+-- @since 0.6 buildTextures ::- ( ArrowQueryReader q,- ArrowDynamicQueryReader q,+ ( Applicative q,+ QueryReaderF q,+ DynamicQueryReaderF q, MonadReaderSystem q s, MonadAccess b m, MonadIO m@@ -218,95 +267,44 @@ windowTextures return go --- | 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_- ( \((camera, cameraTransform), cameraDraws') -> do- rendererScale renderer $= fmap realToFrac (cameraScale camera)- rendererViewport renderer- $= Just- ( Rectangle- (P (fromIntegral <$> transformTranslation cameraTransform))- (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)- ( maybe (fromIntegral <$> V2 (textureWidth textureDesc) (textureHeight textureDesc)) (\(Rectangle _ s) -> fmap fromIntegral s) (surfaceBounds surface)- )- )- )- (realToFrac $ transformRotation transform)- Nothing- (V2 False False)- )- cameraDraws'- )- cameraDraws- rendererDrawColor renderer $= V4 0 0 0 255- present renderer- )- cameraSurfaces- -- | Query all cameras and their target surfaces. ----- @since 0.5+-- @since 0.6 allCameraSurfaces ::- (ArrowQueryReader q, ArrowDynamicQueryReader q, MonadReaderSystem q s) =>+ (Applicative q, QueryReaderF q, DynamicQueryReaderF q, MonadReaderSystem q s) => s [(WindowRenderer, [((Camera, Transform2D), [(Surface, Transform2D, SurfaceTexture)])])] allCameraSurfaces = allWindowDraws- (Q.fetch &&& Q.fetch)- ( proc () -> do- surface <- Q.fetch -< ()- transform <- Q.fetch -< ()- texture <- Q.fetch -< ()- returnA -< (surface, transform, texture)- )+ ((,) <$> Q.fetch <*> Q.fetch)+ $ do+ surface <- Q.fetch+ transform <- Q.fetch+ texture <- Q.fetch+ return (surface, transform, texture) -- | Query all windows and drawable surfaces. ----- @since 0.5+-- @since 0.6 allWindowDraws ::- (ArrowQueryReader q, ArrowDynamicQueryReader q, MonadReaderSystem q s) =>- q () a ->- q () b ->+ (Applicative q, QueryReaderF q, DynamicQueryReaderF 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)- )+ S.all $ do+ eId <- Q.entity+ cameraTarget <- Q.fetch @_ @CameraTarget+ a <- qA+ return (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)- )+ S.all $ do+ t <- Q.fetch @_ @SurfaceTarget+ a <- qB+ return (t, a)+ let cameraDraws = map ( \(eId, cameraTarget, b) ->@@ -336,7 +334,7 @@ -- | Surface target component. -- This component can be used to specify which `Camera` to draw a `Surface` to. ----- @since 0.5+-- @since 0.6 newtype SurfaceTarget = SurfaceTarget {drawTargetCamera :: EntityID} deriving (Eq, Show, Generic, NFData) @@ -345,7 +343,7 @@ -- | Surface component. -- This component can be used to draw to a window. ----- @since 0.5+-- @since 0.6 data Surface = Surface { sdlSurface :: !SDL.Surface, surfaceBounds :: !(Maybe (Rectangle Int))@@ -360,17 +358,18 @@ -- | Add `SurfaceTarget` components to entities with a new `Surface` component. ----- @since 0.5+-- @since 0.6 addSurfaceTargets ::- ( ArrowQueryReader q,- ArrowDynamicQueryReader q,+ ( Applicative q,+ QueryReaderF q,+ DynamicQueryReaderF q, MonadReaderSystem q s, MonadAccess b m ) => s (m ()) addSurfaceTargets = do- cameras <- S.all () (Q.entity &&& Q.fetch @_ @Camera)- newDraws <- S.filter () (Q.entity &&& Q.fetch @_ @Surface) (without @SurfaceTarget)+ 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 ()@@ -378,22 +377,25 @@ -- | Update the current `Time`. ----- @since 0.5+-- @since 0.6 updateTime ::- ( ArrowQuery m q,+ ( Applicative q,+ QueryF m q, MonadSystem q s, MonadIO m ) => s ()-updateTime = void . S.mapSingle () $ Q.adjustM (\_ _ -> Time <$> SDL.ticks)+updateTime = void . S.mapSingle $ Q.adjustM (\_ _ -> Time <$> SDL.ticks) (pure ()) -- | Keyboard input system. ----- @since 0.5+-- @since 0.6 handleInput ::- ( ArrowQueryReader qr,+ ( Applicative qr,+ QueryReaderF qr, MonadReaderSystem qr s,- ArrowQuery m q,+ Applicative q,+ QueryF m q, MonadSystem q s, MonadIO s ) =>@@ -402,9 +404,9 @@ -- | Keyboard input system. ----- @since 0.5+-- @since 0.6 handleInput' ::- (ArrowQueryReader qr, MonadReaderSystem qr s, ArrowQuery m q, MonadSystem q s) =>+ (Applicative qr, QueryReaderF qr, MonadReaderSystem qr s, Applicative q, QueryF m q, MonadSystem q s) => [Event] -> s () handleInput' events = do@@ -438,13 +440,13 @@ ) _ -> (kbAcc, mouseAcc) (updateKb, updateMouse) = foldl' go (id, id) events- _ <- S.map () . Q.adjust $ const updateKb- _ <- S.map () . Q.adjust $ const updateMouse+ _ <- S.mapSingle $ Q.adjust (const updateKb) (pure ())+ _ <- S.mapSingle $ Q.adjust (const updateMouse) (pure ()) return () -- | Convert an SDL mouse button to `MouseButton`. ----- @since 0.5+-- @since 0.6 mouseButtonFromSDL :: SDL.MouseButton -> MouseButton mouseButtonFromSDL b = case b of SDL.ButtonLeft -> ButtonLeft@@ -456,7 +458,7 @@ -- | Convert a `MouseButton` to an SDL mouse button. ----- @since 0.5+-- @since 0.6 mouseButtonToSDL :: MouseButton -> SDL.MouseButton mouseButtonToSDL b = case b of ButtonLeft -> SDL.ButtonLeft@@ -468,7 +470,7 @@ -- | Convert an SDL input motion to `InputMotion`. ----- @since 0.5+-- @since 0.6 motionFromSDL :: SDL.InputMotion -> InputMotion motionFromSDL m = case m of SDL.Pressed -> Pressed@@ -476,7 +478,7 @@ -- | Convert an `InputMotion` to an SDL input motion. ----- @since 0.5+-- @since 0.6 motionToSDL :: InputMotion -> SDL.InputMotion motionToSDL m = case m of Pressed -> SDL.Pressed@@ -484,7 +486,7 @@ -- | Convert an SDL key code to `Key`. ----- @since 0.5+-- @since 0.6 toSDLKeycode :: Key -> SDL.Keycode toSDLKeycode key = case key of KeyA -> SDL.KeycodeA@@ -585,7 +587,7 @@ -- | Convert a `Key` to an SDL key code. ----- @since 0.5+-- @since 0.6 fromSDLKeycode :: SDL.Keycode -> Maybe Key fromSDLKeycode keycode = case keycode of SDL.KeycodeA -> Just KeyA