aztecs-sdl-image 0.5.0 → 0.6.0
raw patch · 2 files changed
+122/−44 lines, 2 filesdep ~aztecsdep ~aztecs-sdldep ~base
Dependency ranges changed: aztecs, aztecs-sdl, base
Files
- aztecs-sdl-image.cabal +4/−4
- src/Aztecs/SDL/Image.hs +118/−40
aztecs-sdl-image.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: aztecs-sdl-image-version: 0.5.0+version: 0.6.0 license: BSD-3-Clause license-file: LICENSE maintainer: matt@hunzinger.me@@ -26,9 +26,9 @@ default-language: Haskell2010 ghc-options: -Wall build-depends:- base >=4.6 && <5,- aztecs >= 0.8 && <0.9,- aztecs-sdl >= 0.5 && <0.6,+ base >=4 && <5,+ aztecs >= 0.9 && <0.10,+ aztecs-sdl >= 0.6 && <0.7, containers >=0.6, deepseq >= 1, mtl >=2,
src/Aztecs/SDL/Image.hs view
@@ -1,8 +1,6 @@ {-# LANGUAGE Arrows #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -10,8 +8,15 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-} +-- |+-- Module : Aztecs.SDL.Image+-- 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.Image ( -- * Components Texture (..),@@ -42,93 +47,159 @@ import qualified Aztecs.ECS.System as S import Aztecs.SDL (Surface (..)) import Aztecs.Time-import Control.Arrow (Arrow (..), (>>>))+import Control.Arrow import Control.DeepSeq+import Control.Monad import Control.Monad.IO.Class-import Data.Maybe (mapMaybe)-import Data.Word (Word32)-import GHC.Generics (Generic)+import Data.Maybe+import Data.Word+import GHC.Generics import SDL hiding (Surface, Texture, Window, windowTitle) import qualified SDL import qualified SDL.Image as IMG -#if !MIN_VERSION_base(4,20,0)-import Data.Foldable (foldl')-#endif--setup :: System () ()-setup = Asset.setup @Texture+-- | Setup image assets+--+-- @since 0.6.0+setup :: (MonadAccess b m) => m ()+setup = Asset.setup @_ @_ @Texture -load :: (MonadIO m) => Schedule m () ()+-- | Load image assets+--+-- @since 0.6.0+load :: (MonadIO m, ArrowQuery m q, MonadSystem q s) => s () load = Asset.loadAssets @Texture -draw :: System () ()-draw = const () <$> (drawImages &&& (animateSprites >>> drawSprites))+-- | Draw images and sprites to their target windows.+--+-- @since 0.6.0+draw ::+ ( ArrowDynamicQueryReader qr,+ ArrowQueryReader qr,+ MonadReaderSystem qr s,+ ArrowQuery m q,+ MonadSystem q s,+ MonadAccess b ma+ ) =>+ s (ma ())+draw = do+ access <- drawImages+ animateSprites+ access' <- drawSprites+ return (access >> access') -- | Texture asset.-newtype Texture = Texture {textureSurface :: SDL.Surface}+--+-- @since 0.6.0+newtype Texture = Texture+ { -- | Texture surface.+ --+ -- @since 0.6.0+ textureSurface :: SDL.Surface+ } +-- | @since 0.6.0 instance Asset Texture where type AssetConfig Texture = () loadAsset path _ = Texture <$> IMG.load path -- | Image component.-newtype Image = Image {imageTexture :: Handle Texture}+--+-- @since 0.6.0+newtype Image = Image+ { -- | Image texture handle.+ --+ -- @since 0.6.0+ imageTexture :: Handle Texture+ } deriving (Generic) deriving newtype (Show, NFData) instance Component Image -- | Draw images to their target windows.-drawImages :: System () ()-drawImages = proc () -> do- imgs <- S.filter (Q.entity &&& Q.fetch @_ @Image) (without @Surface) -< ()- assets <- S.single (Q.fetch @_ @(AssetServer Texture)) -< ()+--+-- @since 0.6.0+drawImages :: (ArrowDynamicQueryReader q, ArrowQueryReader q, MonadReaderSystem q s, MonadAccess b m) => s (m ())+drawImages = do+ imgs <- S.filter () (Q.entity &&& Q.fetch @_ @Image) (without @Surface)+ assets <- S.single () (Q.fetch @_ @(AssetServer Texture)) let newAssets = mapMaybe (\(eId, img) -> (,img,eId) <$> lookupAsset (imageTexture img) assets) imgs- S.queue (mapM_ go) -< newAssets+ return $ mapM_ go newAssets where go (texture, _, eId) =- A.insert eId Surface {sdlSurface = textureSurface texture, surfaceBounds = Nothing}+ A.insert eId $ bundle Surface {sdlSurface = textureSurface texture, surfaceBounds = Nothing} -- | Sprite component.+--+-- @since 0.6.0 data Sprite = Sprite- { spriteTexture :: !(Handle Texture),+ { -- | Sprite texture handle.+ --+ -- @since 0.6.0+ spriteTexture :: !(Handle Texture),+ -- | Sprite bounds.+ --+ -- @since 0.6.0 spriteBounds :: !(Maybe (Rectangle Int)) } deriving (Show) +-- | @since 0.6.0 instance Component Sprite +-- | @since 0.6.0 instance NFData Sprite where- rnf (Sprite texture bounds) = (fmap (fmap rnf) bounds) `seq` rnf texture+ rnf (Sprite texture bounds) = fmap (fmap rnf) bounds `seq` rnf texture -- | Draw images to their target windows.-drawSprites :: System () ()-drawSprites = proc () -> do- sprites <- S.all $ Q.entity &&& Q.fetch -< ()- assets <- S.single (Q.fetch @_ @(AssetServer Texture)) -< ()+--+-- @since 0.6.0+drawSprites :: (ArrowQueryReader q, ArrowDynamicQueryReader q, MonadReaderSystem q s, MonadAccess b m) => s (m ())+drawSprites = do+ sprites <- S.all () $ Q.entity &&& Q.fetch+ assets <- S.single () $ Q.fetch @_ @(AssetServer Texture) let loadedAssets = mapMaybe (\(eId, sprite) -> (,sprite,eId) <$> lookupAsset (spriteTexture sprite) assets) sprites- S.queue (mapM_ go) -< loadedAssets+ return $ mapM_ go loadedAssets where go (texture, sprite, eId) =- A.insert eId Surface {sdlSurface = textureSurface texture, surfaceBounds = spriteBounds sprite}+ A.insert eId $ bundle Surface {sdlSurface = textureSurface texture, surfaceBounds = spriteBounds sprite} -- | Sprite animation component.+--+-- @since 0.6.0 data SpriteAnimation = SpriteAnimation- { spriteAnimationSteps :: ![Rectangle Int],+ { -- | Animation steps.+ --+ -- @since 0.6.0+ spriteAnimationSteps :: ![Rectangle Int],+ -- | Animation step index.+ --+ -- @since 0.6.0 spriteAnimationIndex :: !Int,+ -- | Animation duration (in milliseconds).+ --+ -- @since 0.6.0 spriteAnimationMS :: !Word32,+ -- | Animation start time.+ --+ -- @since 0.6.0 spriteAnimationStart :: !Word32 } deriving (Generic) +-- | @since 0.6.0 instance Component SpriteAnimation +-- | @since 0.6.0 instance NFData SpriteAnimation where- rnf (SpriteAnimation steps index ms start) = (fmap (fmap rnf) steps) `seq` rnf index `seq` rnf ms `seq` rnf start+ rnf (SpriteAnimation steps index ms start) = fmap (fmap rnf) steps `seq` rnf index `seq` rnf ms `seq` rnf start +-- | Empty sprite animation.+--+-- @since 0.6.0 spriteAnimation :: SpriteAnimation spriteAnimation = SpriteAnimation@@ -140,6 +211,8 @@ -- | Create a sprite animation from a grid of sprites, -- given the grid's tile size, and a list of tile indices.+--+-- @since 0.6.0 spriteAnimationGrid :: V2 Int -> [V2 Int] -> SpriteAnimation spriteAnimationGrid (V2 w h) tiles = spriteAnimation@@ -148,11 +221,14 @@ } -- | Query to animate sprites based on the inputted `Time`.-animateSpritesQuery :: Query Time SpriteAnimation+--+-- @since 0.6.0+animateSpritesQuery :: (ArrowQuery m q) => q Time SpriteAnimation animateSpritesQuery = proc currentTime -> do sprite <- Q.fetch @_ @Sprite -< () animation <- Q.fetch @_ @SpriteAnimation -< ()- let sprite' = sprite {spriteBounds = Just $ spriteAnimationSteps animation !! spriteAnimationIndex animation}+ let step = spriteAnimationSteps animation !! spriteAnimationIndex animation+ sprite' = sprite {spriteBounds = Just $ step} animation' = if elapsedMS currentTime - spriteAnimationStart animation > spriteAnimationMS animation then@@ -167,7 +243,9 @@ Q.set -< animation' -- | Animate sprites based on the current `Time`.-animateSprites :: System () ()-animateSprites = proc () -> do- currentTime <- S.single (Q.fetch @_ @Time) -< ()- S.map_ animateSpritesQuery -< currentTime+--+-- @since 0.6.0+animateSprites :: (ArrowQueryReader qr, ArrowQuery m q, MonadReaderSystem qr s, MonadSystem q s) => s ()+animateSprites = do+ currentTime <- S.single () $ Q.fetch @_ @Time+ void $ S.map currentTime animateSpritesQuery