diff --git a/aztecs-sdl.cabal b/aztecs-sdl.cabal --- a/aztecs-sdl.cabal +++ b/aztecs-sdl.cabal @@ -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, diff --git a/src/Aztecs/SDL.hs b/src/Aztecs/SDL.hs --- a/src/Aztecs/SDL.hs +++ b/src/Aztecs/SDL.hs @@ -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 -< ()