aztecs-sdl 0.3.0 → 0.4.0
raw patch · 2 files changed
+100/−51 lines, 2 filesdep ~aztecs
Dependency ranges changed: aztecs
Files
- aztecs-sdl.cabal +4/−4
- src/Aztecs/SDL.hs +96/−47
aztecs-sdl.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: aztecs-sdl-version: 0.3.0+version: 0.4.0 license: BSD-3-Clause license-file: LICENSE maintainer: matt@hunzinger.me@@ -12,12 +12,12 @@ 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+homepage: https://github.com/aztecs-hs/aztecs-sdl category: Game Engine source-repository head type: git- location: https://github.com/matthunz/aztecs.git+ location: https://github.com/aztecs-hs/aztecs-sdl.git library exposed-modules:@@ -27,7 +27,7 @@ ghc-options: -Wall build-depends: base >=4.6 && <5,- aztecs >= 0.6 && <0.7,+ aztecs >= 0.7 && <0.8, containers >=0.6, deepseq >=1, mtl >=2,
src/Aztecs/SDL.hs view
@@ -1,13 +1,9 @@ {-# LANGUAGE Arrows #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeOperators #-} module Aztecs.SDL ( -- * Window components@@ -48,28 +44,21 @@ ) where -import Aztecs.Camera (Camera (..), CameraTarget (..), addCameraTargets)-import Aztecs.ECS+import Aztecs+import Aztecs.Camera (addCameraTargets) import qualified Aztecs.ECS.Access as A import qualified Aztecs.ECS.Query as Q-import Aztecs.ECS.Query.Reader (ArrowQueryReader)-import Aztecs.ECS.System (ArrowReaderSystem) import qualified Aztecs.ECS.System as S import Aztecs.Input ( InputMotion (..),- Key (..),- KeyboardInput (..), MouseButton (..),- MouseInput (..), handleKeyboardEvent, keyboardInput, mouseInput, )-import Aztecs.Time-import Aztecs.Transform (Size (..), Transform (..))-import Aztecs.Window import Control.Arrow (Arrow (..), returnA, (>>>)) import Control.DeepSeq+import Control.Monad.IO.Class import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Text as T@@ -96,34 +85,54 @@ rnf = rwhnf -- | Setup SDL-setup :: Schedule IO () ()+setup :: (MonadIO m) => (ArrowAccessSchedule b m arr) => arr () () setup =- fmap (const ()) $- task (const initializeAll)- &&& system- ( S.queue- ( const $ do- A.spawn_ . bundle $ Time 0- A.spawn_ $ bundle keyboardInput- A.spawn_ $ bundle mouseInput- )- )+ access (const $ liftIO initializeAll)+ >>> access+ ( const $ do+ A.spawn_ . bundle $ Time 0+ A.spawn_ $ bundle keyboardInput+ A.spawn_ $ bundle mouseInput+ ) -- | Update SDL windows-update :: Schedule IO () ()+update ::+ ( ArrowQueryReader qr,+ ArrowDynamicQueryReader qr,+ ArrowReaderSystem qr rs,+ ArrowQueueSystem b qm rs,+ ArrowReaderSchedule rs arr,+ ArrowQuery q,+ ArrowSystem q s,+ ArrowReaderSystem qr s,+ ArrowQueueSystem b qm s,+ ArrowSchedule s arr,+ MonadIO m,+ ArrowAccessSchedule b m arr+ ) =>+ arr () () update = updateTime >>> addWindows- >>> system (addCameraTargets >>> addSurfaceTargets)+ >>> reader (addCameraTargets >>> addSurfaceTargets) >>> buildTextures >>> handleInput -- | Setup new windows.-addWindows :: Schedule IO () ()+addWindows ::+ ( ArrowQueryReader q,+ ArrowDynamicQueryReader q,+ ArrowReaderSystem q s,+ ArrowQueueSystem b qm s,+ ArrowReaderSchedule s arr,+ MonadIO m,+ ArrowAccessSchedule b m arr+ ) =>+ arr () () addWindows = proc () -> do newWindows <- reader $ S.filter (Q.entity &&& Q.fetch @_ @Window) (without @WindowRenderer) -< ()- newWindows' <- task $ mapM createWindowRenderer -< newWindows- system $ S.queue $ mapM_ insertWindowRenderer -< newWindows'+ newWindows' <- access $ liftIO . mapM createWindowRenderer -< newWindows+ reader $ S.queue $ mapM_ insertWindowRenderer -< newWindows' where createWindowRenderer (eId, window) = do sdlWindow <- createWindow (T.pack $ windowTitle window) defaultWindow@@ -144,11 +153,11 @@ rnf = rwhnf allWindowTextures ::- (ArrowQueryReader q, ArrowReaderSystem q arr, Applicative (q ())) =>- arr () [(WindowRenderer, [(EntityID, Surface, Transform, Maybe SurfaceTexture)])]+ (ArrowQueryReader q, ArrowDynamicQueryReader q, ArrowReaderSystem q arr) =>+ arr () [(WindowRenderer, [(EntityID, Surface, Transform2D, Maybe SurfaceTexture)])] allWindowTextures = allWindowDraws- (pure ())+ (arr (const ())) ( proc () -> do e <- Q.entity -< () surface <- Q.fetch -< ()@@ -159,7 +168,15 @@ >>> arr (\cs -> map (\(w, cs') -> (w, concatMap snd cs')) cs) -- | Build textures from surfaces in preparation for `drawTextures`.-buildTextures :: Schedule IO () ()+buildTextures ::+ ( ArrowQueryReader q,+ ArrowDynamicQueryReader q,+ ArrowReaderSystem q s,+ ArrowReaderSchedule s arr,+ MonadIO m,+ ArrowAccessSchedule b m arr+ ) =>+ arr () () buildTextures = let go windowDraws = mapM_@@ -187,7 +204,15 @@ windowDraws in reader allWindowTextures >>> access go -draw :: Schedule IO () ()+draw ::+ ( ArrowQueryReader q,+ ArrowDynamicQueryReader q,+ ArrowReaderSystem q s,+ ArrowReaderSchedule s arr,+ MonadIO m,+ ArrowAccessSchedule b m arr+ ) =>+ arr () () draw = let go windowDraws = mapM_@@ -200,7 +225,7 @@ rendererViewport renderer $= Just ( Rectangle- (P (fmap fromIntegral $ transformPosition cameraTransform))+ (P (fmap fromIntegral $ transformTranslation cameraTransform)) (fmap fromIntegral $ cameraViewport camera) ) clear renderer@@ -213,7 +238,7 @@ (fmap fromIntegral <$> surfaceBounds surface) ( Just ( Rectangle- (fmap fromIntegral . P $ transformPosition transform)+ (fmap fromIntegral . P $ transformTranslation transform) ( fromMaybe (fmap fromIntegral $ V2 (textureWidth textureDesc) (textureHeight textureDesc)) ((fmap (\(Rectangle _ s) -> fmap fromIntegral s) $ surfaceBounds surface))@@ -233,8 +258,8 @@ in reader allCameraSurfaces >>> access go allCameraSurfaces ::- (ArrowQueryReader q, ArrowReaderSystem q arr) =>- arr () [(WindowRenderer, [((Camera, Transform), [(Surface, Transform, SurfaceTexture)])])]+ (ArrowQueryReader q, ArrowDynamicQueryReader q, ArrowReaderSystem q arr) =>+ arr () [(WindowRenderer, [((Camera, Transform2D), [(Surface, Transform2D, SurfaceTexture)])])] allCameraSurfaces = allWindowDraws (Q.fetch &&& Q.fetch)@@ -246,7 +271,7 @@ ) allWindowDraws ::- (ArrowQueryReader q, ArrowReaderSystem q arr) =>+ (ArrowQueryReader q, ArrowDynamicQueryReader q, ArrowReaderSystem q arr) => (q () a) -> (q () b) -> arr () [(WindowRenderer, [(a, [b])])]@@ -317,7 +342,13 @@ rnf = rwhnf -- | Add `SurfaceTarget` components to entities with a new `Surface` component.-addSurfaceTargets :: System () ()+addSurfaceTargets ::+ ( ArrowQueryReader q,+ ArrowDynamicQueryReader q,+ ArrowReaderSystem q arr,+ ArrowQueueSystem b m arr+ ) =>+ arr () () addSurfaceTargets = proc () -> do cameras <- S.all (Q.entity &&& Q.fetch @_ @Camera) -< () newDraws <- S.filter (Q.entity &&& Q.fetch @_ @Surface) (without @SurfaceTarget) -< ()@@ -329,17 +360,35 @@ -< (newDraws, cameras) -updateTime :: Schedule IO () ()+updateTime ::+ ( ArrowQuery q,+ ArrowSystem q s,+ ArrowSchedule s arr,+ MonadIO m,+ ArrowAccessSchedule b m arr+ ) =>+ arr () () updateTime = proc () -> do- t <- task (const SDL.ticks) -< ()+ t <- access . const $ liftIO SDL.ticks -< () system $ S.mapSingle Q.set -< Time t returnA -< () -handleInput :: Schedule IO () ()-handleInput = task (const pollEvents) >>> system handleInput'+handleInput ::+ ( ArrowQueryReader qr,+ ArrowReaderSystem qr s,+ ArrowQuery q,+ ArrowSystem q s,+ ArrowSchedule s arr,+ MonadIO m,+ ArrowAccessSchedule b m arr+ ) =>+ arr () ()+handleInput = access (const pollEvents) >>> system handleInput' -- | Keyboard input system.-handleInput' :: System [Event] ()+handleInput' ::+ (ArrowQueryReader qr, ArrowReaderSystem qr arr, ArrowQuery q, ArrowSystem q arr) =>+ arr [Event] () handleInput' = proc events -> do kb <- S.single Q.fetch -< () mouse <- S.single Q.fetch -< ()