aztecs-sdl (empty) → 0.1.0.0
raw patch · 4 files changed
+362/−0 lines, 4 filesdep +aztecsdep +aztecs-assetdep +aztecs-sdl
Dependencies added: aztecs, aztecs-asset, aztecs-sdl, aztecs-transform, base, containers, linear, mtl, sdl2, sdl2-image, text
Files
- LICENSE +29/−0
- aztecs-sdl.cabal +51/−0
- examples/Window.hs +42/−0
- src/Data/Aztecs/SDL.hs +240/−0
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2024, Matt Hunzinger+++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of the copyright holder nor the names of its+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ aztecs-sdl.cabal view
@@ -0,0 +1,51 @@+cabal-version: 2.4+name: aztecs-sdl+version: 0.1.0.0+license: BSD-3-Clause+license-file: LICENSE+maintainer: matt@hunzinger.me+author: Matt Hunzinger+synopsis: A type-safe and friendly Entity-Component-System (ECS) for Haskell+description: The Entity-Component-System (ECS) pattern is commonly used in video game develop to represent world objects.+ .+ ECS follows the principal of composition over inheritence. Each type of+ object (e.g. sword, monster, etc), in the game has a unique EntityId. Each+ entity has various Components associated with it (material, weight, damage, etc).+ Systems act on entities which have the required Components.+homepage: https://github.com/matthunz/aztecs+category: Game Engine++source-repository head+ type: git+ location: https://github.com/matthunz/aztecs.git++library+ exposed-modules:+ Data.Aztecs.SDL+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall+ build-depends:+ base >=4 && <5,+ aztecs >= 0.3,+ aztecs-asset >= 0.1,+ aztecs-transform >= 0.1,+ containers >=0.7,+ mtl >=2,+ sdl2 >=2,+ sdl2-image >=2,+ text >=1.2,+ linear >= 1++executable window+ main-is: Window.hs+ hs-source-dirs: examples+ default-language: Haskell2010+ ghc-options: -Wall+ build-depends:+ base >=4 && <5,+ aztecs-sdl,+ aztecs >= 0.3,+ aztecs-asset >= 0.1,+ aztecs-transform >= 0.1,+ sdl2 >=2
+ examples/Window.hs view
@@ -0,0 +1,42 @@+{-# 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 (Image (..), Window (..))+import qualified Data.Aztecs.SDL as SDL+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.run (load "example.png") -< assetServer+ Q.set -< assetServer'+ returnA -< texture+ )+ >>> S.queue+ ( \texture -> do+ A.spawn_ $ bundle Window {windowTitle = "Aztecs"}+ A.spawn_ $+ bundle Image {imageTexture = texture, imageSize = V2 100 100}+ <> bundle transform {transformPosition = V2 100 100}+ A.spawn_ $+ bundle Image {imageTexture = texture, imageSize = V2 200 200}+ <> bundle transform {transformPosition = V2 500 100}+ )++update :: System () ()+update = S.all (Q.fetch @_ @SDL.Keyboard) >>> S.run (\keyboard -> print keyboard)++main :: IO ()+main = runSystem_ $ SDL.setup >>> setup >>> S.forever (SDL.update >>> update >>> SDL.draw)
+ src/Data/Aztecs/SDL.hs view
@@ -0,0 +1,240 @@+{-# LANGUAGE Arrows #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++module Data.Aztecs.SDL where++import Control.Arrow (Arrow (..), returnA, (>>>))+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 qualified Data.Aztecs.System as S+import Data.Aztecs.Transform (Transform (..))+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (mapMaybe)+import qualified Data.Text as T+import Foreign.C (CInt)+import SDL hiding (Texture, Window, windowTitle)+import qualified SDL hiding (Texture)+import qualified SDL.Image as IMG++-- | Window component.+data Window = Window+ { windowTitle :: String+ }+ deriving (Show)++instance Component Window++-- | Window renderer component.+data WindowRenderer = WindowRenderer+ { windowRendererRaw :: SDL.Window,+ windowRenderer :: Renderer+ }+ deriving (Show)++instance Component WindowRenderer++-- | Setup SDL+setup :: System () ()+setup =+ fmap (const ()) $+ Asset.setup @Texture+ &&& S.run (const initializeAll)+ &&& S.queue (const . A.spawn_ . bundle $ Keyboard mempty)++-- | Update SDL windows+update :: System () ()+update =+ addWindows+ >>> addWindowTargets+ >>> Asset.loadAssets @Texture+ >>> keyboardInput++draw :: System () ()+draw = drawImages >>> renderWindows++-- | Setup new windows.+addWindows :: System () ()+addWindows = proc () -> do+ newWindows <- S.filter (Q.entity &&& Q.fetch @_ @Window) (without @WindowRenderer) -< ()+ newWindows' <- S.run createNewWindows -< newWindows+ S.queue insertNewWindows -< newWindows'+ where+ createNewWindows newWindows = mapM createWindowRenderer newWindows+ createWindowRenderer (eId, window) = do+ sdlWindow <- createWindow (T.pack $ windowTitle window) defaultWindow+ renderer <- createRenderer sdlWindow (-1) defaultRenderer+ return (eId, sdlWindow, renderer)+ insertNewWindows newWindows' = mapM_ insertWindowRenderer newWindows'+ insertWindowRenderer (eId, window, renderer) = A.insert eId (WindowRenderer window renderer)++-- | Render windows.+renderWindows :: System () ()+renderWindows =+ let go windowDraws =+ mapM_+ ( \(window, draws) -> do+ let renderer = windowRenderer window+ rendererDrawColor renderer $= V4 0 0 0 255+ clear renderer+ mapM_ (\(d, transform) -> runDraw d transform renderer) draws+ present renderer+ )+ windowDraws+ in proc () -> do+ windows <- S.all (Q.entity &&& Q.fetch @_ @WindowRenderer) -< ()+ draws <-+ S.all+ ( proc () -> do+ d <- Q.fetch @_ @Draw -< ()+ transform <- Q.fetch @_ @Transform -< ()+ target <- Q.fetch @_ @WindowTarget -< ()+ returnA -< (d, transform, target)+ )+ -<+ ()+ let windowDraws =+ foldr+ ( \(eId, window) acc ->+ let draws' =+ foldr+ ( \(d, transform, target) acc' ->+ if unWindowTarget target == eId+ then (d, transform) : acc'+ else acc'+ )+ []+ draws+ in (window, draws') : acc+ )+ []+ windows+ S.run go -< windowDraws++-- | Window target component.+-- This component can be used to specify which `Window` to draw an entity to.+newtype WindowTarget = WindowTarget {unWindowTarget :: EntityID}+ deriving (Eq, Show)++instance Component WindowTarget++-- | Draw component.+-- This component can be used to draw to a window.+newtype Draw = Draw {runDraw :: Transform -> Renderer -> IO ()}++instance Component Draw++-- | Add `WindowTarget` components to entities with a new `Draw` component.+addWindowTargets :: System () ()+addWindowTargets = proc () -> do+ windows <- S.all (Q.entity &&& Q.fetch @_ @WindowRenderer) -< ()+ newDraws <- S.filter (Q.entity &&& Q.fetch @_ @Draw) (without @WindowTarget) -< ()+ S.queue+ ( \(newDraws, windows) -> case windows of+ (windowEId, _) : _ -> mapM_ (\(eId, _) -> A.insert eId $ WindowTarget windowEId) newDraws+ _ -> return ()+ )+ -<+ (newDraws, windows)++-- | Draw a rectangle.+rect :: V2 Int -> Draw+rect size = Draw $+ \transform renderer -> do+ surface <- createRGBSurface (fmap fromIntegral size) RGBA8888+ surfaceRenderer <- createSoftwareRenderer surface+ rendererDrawColor surfaceRenderer $= V4 255 0 0 255+ fillRect surfaceRenderer Nothing+ texture <- SDL.createTextureFromSurface renderer surface+ copyEx+ renderer+ texture+ Nothing+ (Just (Rectangle (fmap (fromIntegral @CInt . round) . P $ transformPosition transform) (fmap fromIntegral size)))+ (realToFrac $ transformRotation transform)+ Nothing+ (V2 False False)+ freeSurface surface+ destroyTexture texture++-- | Texture asset.+newtype Texture = Texture {textureSurface :: Surface}++instance Asset Texture where+ 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 @Draw) -< ()+ 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, img, eId) = do+ A.insert+ eId+ ( Draw $+ \transform renderer -> do+ sdlTexture <- SDL.createTextureFromSurface renderer (textureSurface texture)+ copyEx+ renderer+ sdlTexture+ Nothing+ ( Just+ ( Rectangle+ (fmap (fromIntegral @CInt . round) . P $ transformPosition transform)+ (fmap fromIntegral $ imageSize img)+ )+ )+ (realToFrac $ transformRotation transform)+ Nothing+ (V2 False False)+ destroyTexture sdlTexture+ )++-- | Keyboard state.+newtype Keyboard = Keyboard {unKeyboard :: Map Keycode InputMotion}+ deriving (Show, Semigroup, Monoid)++instance Component Keyboard++-- | Keyboard input system.+keyboardInput :: System () ()+keyboardInput = proc () -> do+ events <- S.run . const $ SDL.pollEvents -< ()+ S.mapSingle+ ( proc events -> do+ let go event keyAcc = case eventPayload event of+ KeyboardEvent keyboardEvent ->+ Keyboard $+ Map.insert+ (keysymKeycode $ keyboardEventKeysym keyboardEvent)+ (keyboardEventKeyMotion keyboardEvent)+ (unKeyboard keyAcc)+ _ -> keyAcc+ keyboard <- Q.fetch -< ()+ Q.set -< foldr go keyboard events+ )+ -<+ events+ returnA -< ()