diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/aztecs-sdl.cabal b/aztecs-sdl.cabal new file mode 100644 --- /dev/null +++ b/aztecs-sdl.cabal @@ -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 diff --git a/examples/Window.hs b/examples/Window.hs new file mode 100644 --- /dev/null +++ b/examples/Window.hs @@ -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) diff --git a/src/Data/Aztecs/SDL.hs b/src/Data/Aztecs/SDL.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aztecs/SDL.hs @@ -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 -< ()