aztecs-sdl-image 0.2.0.1 → 0.3.0
raw patch · 5 files changed
+187/−313 lines, 5 filesdep +deepseqdep −aztecs-assetdep −aztecs-sdl-imagedep −aztecs-transformdep ~aztecsdep ~aztecs-sdldep ~base
Dependencies added: deepseq
Dependencies removed: aztecs-asset, aztecs-sdl-image, aztecs-transform
Dependency ranges changed: aztecs, aztecs-sdl, base, sdl2
Files
- aztecs-sdl-image.cabal +4/−30
- examples/Image.hs +0/−53
- examples/Sprite.hs +0/−59
- src/Aztecs/SDL/Image.hs +183/−0
- src/Data/Aztecs/SDL/Image.hs +0/−171
aztecs-sdl-image.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: aztecs-sdl-image-version: 0.2.0.1+version: 0.3.0 license: BSD-3-Clause license-file: LICENSE maintainer: matt@hunzinger.me@@ -19,46 +19,20 @@ type: git location: https://github.com/matthunz/aztecs.git -flag examples- description: Build examples- default: False- manual: True- library exposed-modules:- Data.Aztecs.SDL.Image+ Aztecs.SDL.Image hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall build-depends: base >=4.6 && <5,- aztecs >= 0.3,- aztecs-asset >= 0.1,+ aztecs >= 0.5, aztecs-sdl >= 0.1,- aztecs-transform >= 0.1, containers >=0.6,+ deepseq >= 1, mtl >=2, sdl2 >=2, sdl2-image >=2, text >=1.2, linear >= 1--executable image- main-is: Image.hs- hs-source-dirs: examples- default-language: Haskell2010- ghc-options: -Wall- if flag(examples)- build-depends: base, aztecs, aztecs-sdl, aztecs-sdl-image, aztecs-asset, aztecs-transform, sdl2- else- buildable: False--executable sprite- main-is: Sprite.hs- hs-source-dirs: examples- default-language: Haskell2010- ghc-options: -Wall- if flag(examples)- build-depends: base, aztecs, aztecs-sdl, aztecs-sdl-image, aztecs-asset, aztecs-transform, sdl2- else- buildable: False
− examples/Image.hs
@@ -1,53 +0,0 @@-{-# LANGUAGE Arrows #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeApplications #-}--module Main where--import Control.Arrow (returnA, (>>>))-import Data.Aztecs-import qualified Data.Aztecs.Access as A-import Data.Aztecs.Asset (load)-import qualified Data.Aztecs.Query as Q-import Data.Aztecs.SDL (Camera (..), Window (..))-import qualified Data.Aztecs.SDL as SDL-import Data.Aztecs.SDL.Image (Image (..))-import qualified Data.Aztecs.SDL.Image as IMG-import qualified Data.Aztecs.System as S-import Data.Aztecs.Transform (Transform (..), transform)-import SDL (V2 (..))--setup :: System () ()-setup =- S.mapSingle- ( proc () -> do- assetServer <- Q.fetch -< ()- (texture, assetServer') <- Q.task $ load "assets/example.png" () -< assetServer- Q.set -< assetServer'- returnA -< texture- )- >>> S.queue- ( \texture -> do- A.spawn_ $ bundle Window {windowTitle = "Aztecs"}- A.spawn_ $- bundle Camera {cameraViewport = V2 1000 500, cameraScale = 5}- <> bundle transform- A.spawn_ $- bundle Image {imageTexture = texture, imageSize = V2 100 100}- <> bundle transform {transformPosition = V2 10 10}- )--app :: Schedule IO () ()-app =- schedule SDL.setup- >>> schedule IMG.setup- >>> schedule setup- >>> forever- ( schedule IMG.load- >>> schedule SDL.update- >>> schedule IMG.draw- >>> schedule SDL.draw- )--main :: IO ()-main = runSchedule_ app
− examples/Sprite.hs
@@ -1,59 +0,0 @@-{-# LANGUAGE Arrows #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeApplications #-}--module Main where--import Control.Arrow (returnA, (>>>))-import Data.Aztecs-import qualified Data.Aztecs.Access as A-import Data.Aztecs.Asset (load)-import qualified Data.Aztecs.Query as Q-import Data.Aztecs.SDL (Camera (..), Window (..))-import qualified Data.Aztecs.SDL as SDL-import Data.Aztecs.SDL.Image (Sprite (..), spriteAnimationGrid)-import qualified Data.Aztecs.SDL.Image as IMG-import qualified Data.Aztecs.System as S-import Data.Aztecs.Transform (Transform (..), transform)-import SDL (Point (..), Rectangle (..), V2 (..))--setup :: System () ()-setup =- S.mapSingle- ( proc () -> do- assetServer <- Q.fetch -< ()- (texture, assetServer') <- Q.task $ load "assets/characters.png" () -< assetServer- Q.set -< assetServer'- returnA -< texture- )- >>> S.queue- ( \texture -> do- A.spawn_ $ bundle Window {windowTitle = "Aztecs"}- A.spawn_ $- bundle Camera {cameraViewport = V2 1000 500, cameraScale = 5}- <> bundle transform- A.spawn_ $- bundle- Sprite- { spriteTexture = texture,- spriteSize = V2 300 300,- spriteBounds = Just $ Rectangle (P $ V2 0 32) (V2 32 32)- }- <> bundle (spriteAnimationGrid (V2 576 32) (V2 32 32) 3)- <> bundle transform {transformPosition = V2 10 10}- )--app :: Schedule IO () ()-app =- schedule SDL.setup- >>> schedule IMG.setup- >>> schedule setup- >>> forever- ( schedule IMG.load- >>> schedule SDL.update- >>> schedule IMG.draw- >>> schedule SDL.draw- )--main :: IO ()-main = runSchedule_ app
+ src/Aztecs/SDL/Image.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE Arrows #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module Aztecs.SDL.Image+ ( -- * Components+ Texture (..),+ Image (..),+ Sprite (..),+ SpriteAnimation (..),+ spriteAnimation,+ spriteAnimationGrid,++ -- * Systems+ setup,+ load,+ draw,++ -- ** Primitive systems+ drawImages,+ drawSprites,+ animateSprites,+ animateSpritesQuery,+ )+where++import Aztecs.Asset (Asset (..), AssetServer, Handle, lookupAsset)+import qualified Aztecs.Asset as Asset+import Aztecs.ECS+import qualified Aztecs.ECS.Access as A+import qualified Aztecs.ECS.Query as Q+import qualified Aztecs.ECS.System as S+import Aztecs.SDL (Surface (..))+import Aztecs.Time+import Control.Arrow (Arrow (..), (>>>))+import Control.DeepSeq+import Data.Maybe (mapMaybe)+import Data.Word (Word32)+import GHC.Generics (Generic)+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++load :: Schedule IO () ()+load = Asset.loadAssets @Texture++draw :: System () ()+draw = const () <$> (drawImages &&& (animateSprites >>> drawSprites))++-- | Texture asset.+newtype Texture = Texture {textureSurface :: SDL.Surface}++instance Asset Texture where+ type AssetConfig Texture = ()+ loadAsset path _ = Texture <$> IMG.load path++-- | Image component.+data Image = Image+ { imageTexture :: !(Handle Texture),+ imageSize :: !(V2 Int)+ }+ deriving (Show, Generic, 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)) -< ()+ let newAssets =+ mapMaybe (\(eId, img) -> (,img,eId) <$> lookupAsset (imageTexture img) assets) imgs+ S.queue (mapM_ go) -< newAssets+ where+ go (texture, _, eId) = do+ A.insert+ eId+ Surface+ { sdlSurface = textureSurface texture,+ surfaceBounds = Nothing+ }++-- | Sprite component.+data Sprite = Sprite+ { spriteTexture :: !(Handle Texture),+ spriteBounds :: !(Maybe (Rectangle Int)),+ spriteSize :: !(V2 Int)+ }+ deriving (Show)++instance Component Sprite++instance NFData Sprite where+ rnf (Sprite texture bounds size) = rnf texture `seq` (fmap (fmap rnf) bounds) `seq` rnf size++-- | 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)) -< ()+ let loadedAssets =+ mapMaybe (\(eId, sprite) -> (,sprite,eId) <$> lookupAsset (spriteTexture sprite) assets) sprites+ S.queue (mapM_ go) -< loadedAssets+ where+ go (texture, sprite, eId) = do+ A.insert+ eId+ Surface+ { sdlSurface = textureSurface texture,+ surfaceBounds = spriteBounds sprite+ }++data SpriteAnimation = SpriteAnimation+ { spriteAnimationSteps :: ![Rectangle Int],+ spriteAnimationIndex :: !Int,+ spriteAnimationMS :: !Word32,+ spriteAnimationStart :: !Word32+ }+ deriving (Generic)++instance Component SpriteAnimation++instance NFData SpriteAnimation where+ rnf (SpriteAnimation steps index ms start) = (fmap (fmap rnf) steps) `seq` rnf index `seq` rnf ms `seq` rnf start++spriteAnimation :: SpriteAnimation+spriteAnimation =+ SpriteAnimation+ { spriteAnimationSteps = [],+ spriteAnimationIndex = 0,+ spriteAnimationMS = 100,+ spriteAnimationStart = 0+ }++-- | Create a sprite animation from a grid of sprites,+-- given the grid's tile size, and a list of tile indices.+spriteAnimationGrid :: V2 Int -> [V2 Int] -> SpriteAnimation+spriteAnimationGrid (V2 w h) tiles =+ spriteAnimation+ { spriteAnimationSteps =+ map (\(V2 x y) -> Rectangle (P $ V2 (x * w) (y * h)) (V2 w h)) tiles+ }++-- | Query to animate sprites based on the inputted `Time`.+animateSpritesQuery :: Query Time SpriteAnimation+animateSpritesQuery = proc currentTime -> do+ sprite <- Q.fetch @_ @Sprite -< ()+ animation <- Q.fetch @_ @SpriteAnimation -< ()+ let sprite' = sprite {spriteBounds = Just $ spriteAnimationSteps animation !! spriteAnimationIndex animation}+ animation' =+ if elapsedMS currentTime - spriteAnimationStart animation > spriteAnimationMS animation+ then+ animation+ { spriteAnimationIndex =+ (spriteAnimationIndex animation + 1)+ `mod` length (spriteAnimationSteps animation),+ spriteAnimationStart = elapsedMS currentTime+ }+ else animation+ Q.set -< sprite'+ 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
− src/Data/Aztecs/SDL/Image.hs
@@ -1,171 +0,0 @@-{-# LANGUAGE Arrows #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}--module Data.Aztecs.SDL.Image- ( -- * Components- Texture (..),- Image (..),- Sprite (..),- SpriteAnimation (..),- spriteAnimation,- spriteAnimationGrid,-- -- * Systems- setup,- load,- draw,-- -- ** Primitive systems- drawImages,- drawSprites,- animateSprites,- animateSpritesQuery,- )-where--import Control.Arrow (Arrow (..), (>>>))-import Data.Aztecs-import qualified Data.Aztecs.Access as A-import Data.Aztecs.Asset (Asset (..), AssetServer, Handle, lookupAsset)-import qualified Data.Aztecs.Asset as Asset-import qualified Data.Aztecs.Query as Q-import Data.Aztecs.SDL (Surface (..), Time (..))-import qualified Data.Aztecs.System as S-import Data.Maybe (mapMaybe)-import Data.Word (Word32)-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--load :: System () ()-load = Asset.loadAssets @Texture--draw :: System () ()-draw = const () <$> (drawImages &&& (animateSprites >>> drawSprites))---- | Texture asset.-newtype Texture = Texture {textureSurface :: SDL.Surface}--instance Asset Texture where- type AssetConfig Texture = ()- loadAsset path _ = Texture <$> IMG.load path---- | Image component.-data Image = Image- { imageTexture :: !(Handle Texture),- imageSize :: !(V2 Int)- }- deriving (Show)--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)) -< ()- let newAssets =- mapMaybe (\(eId, img) -> (,img,eId) <$> lookupAsset (imageTexture img) assets) imgs- S.queue (mapM_ go) -< newAssets- where- go (texture, _, eId) = do- A.insert- eId- Surface- { sdlSurface = textureSurface texture,- surfaceBounds = Nothing- }---- | Sprite component.-data Sprite = Sprite- { spriteTexture :: !(Handle Texture),- spriteBounds :: !(Maybe (Rectangle Int)),- spriteSize :: !(V2 Int)- }- deriving (Show)--instance Component Sprite---- | 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)) -< ()- let loadedAssets =- mapMaybe (\(eId, sprite) -> (,sprite,eId) <$> lookupAsset (spriteTexture sprite) assets) sprites- S.queue (mapM_ go) -< loadedAssets- where- go (texture, sprite, eId) = do- A.insert- eId- Surface- { sdlSurface = textureSurface texture,- surfaceBounds = spriteBounds sprite- }--data SpriteAnimation = SpriteAnimation- { spriteAnimationSteps :: ![Rectangle Int],- spriteAnimationIndex :: !Int,- spriteAnimationMS :: !Word32,- spriteAnimationStart :: !Word32- }--instance Component SpriteAnimation--spriteAnimation :: SpriteAnimation-spriteAnimation =- SpriteAnimation- { spriteAnimationSteps = [],- spriteAnimationIndex = 0,- spriteAnimationMS = 100,- spriteAnimationStart = 0- }---- | Create a sprite animation from a grid of sprites,--- given the grid's offset, size, and number of tiles.-spriteAnimationGrid :: V2 Int -> V2 Int -> Int -> SpriteAnimation-spriteAnimationGrid (V2 x y) (V2 w h) n =- spriteAnimation- { spriteAnimationSteps =- map (\i -> Rectangle (P $ V2 (x + i * w) y) (V2 w h)) [0 .. n]- }---- | Query to animate sprites based on the inputted `Time`.-animateSpritesQuery :: (Monad m) => Query m Time SpriteAnimation-animateSpritesQuery = proc currentTime -> do- sprite <- Q.fetch @_ @Sprite -< ()- animation <- Q.fetch @_ @SpriteAnimation -< ()- let sprite' = sprite {spriteBounds = Just $ spriteAnimationSteps animation !! spriteAnimationIndex animation}- animation' =- if elapsedMS currentTime - spriteAnimationStart animation > spriteAnimationMS animation- then- animation- { spriteAnimationIndex =- (spriteAnimationIndex animation + 1)- `mod` length (spriteAnimationSteps animation),- spriteAnimationStart = elapsedMS currentTime- }- else animation- Q.set -< sprite'- 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