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.2.0.1 +version: 0.3.0 license: BSD-3-Clause license-file: LICENSE maintainer: matt@hunzinger.me @@ -19,55 +19,18 @@ type: git location: https://github.com/matthunz/aztecs.git -flag examples - description: Build examples - default: False - manual: True - library exposed-modules: - Data.Aztecs.SDL + Aztecs.SDL hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall build-depends: base >=4.6 && <5, - aztecs >= 0.5, - aztecs-asset >= 0.2, - aztecs-transform >= 0.2, + aztecs >= 0.6 && <0.7, containers >=0.6, + deepseq >=1, mtl >=2, sdl2 >=2, text >=1.2, linear >= 1 - -executable keyboard - main-is: Keyboard.hs - hs-source-dirs: examples - default-language: Haskell2010 - ghc-options: -Wall - if flag(examples) - build-depends: base, aztecs, aztecs-sdl, aztecs-asset, aztecs-transform, sdl2 - else - buildable: False - - -executable mouse - main-is: Mouse.hs - hs-source-dirs: examples - default-language: Haskell2010 - ghc-options: -Wall - if flag(examples) - build-depends: base, aztecs, aztecs-sdl, aztecs-asset, aztecs-transform, sdl2 - else - buildable: False - -executable window - main-is: Window.hs - hs-source-dirs: examples - default-language: Haskell2010 - ghc-options: -Wall - if flag(examples) - build-depends: base, aztecs, aztecs-sdl, aztecs-asset, aztecs-transform, sdl2 - else - buildable: False diff --git a/examples/Keyboard.hs b/examples/Keyboard.hs deleted file mode 100644 --- a/examples/Keyboard.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE Arrows #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeApplications #-} - -module Main where - -import Control.Arrow ((>>>)) -import Data.Aztecs -import qualified Data.Aztecs.Access as A -import qualified Data.Aztecs.Query as Q -import Data.Aztecs.SDL (KeyboardInput, Window (..)) -import qualified Data.Aztecs.SDL as SDL -import qualified Data.Aztecs.System as S - -setup :: System () () -setup = S.queue . const . A.spawn_ $ bundle Window {windowTitle = "Aztecs"} - -update :: System () () -update = S.all (Q.fetch @_ @KeyboardInput) >>> S.task print - -main :: IO () -main = - runSchedule_ $ - schedule SDL.setup - >>> schedule setup - >>> forever (schedule SDL.update >>> schedule update >>> schedule SDL.draw) diff --git a/examples/Mouse.hs b/examples/Mouse.hs deleted file mode 100644 --- a/examples/Mouse.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE Arrows #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeApplications #-} - -module Main where - -import Control.Arrow ((>>>)) -import Data.Aztecs -import qualified Data.Aztecs.Access as A -import qualified Data.Aztecs.Query as Q -import Data.Aztecs.SDL (MouseInput, Window (..)) -import qualified Data.Aztecs.SDL as SDL -import qualified Data.Aztecs.System as S - -setup :: System () () -setup = S.queue . const . A.spawn_ $ bundle Window {windowTitle = "Aztecs"} - -update :: System () () -update = S.all (Q.fetch @_ @MouseInput) >>> S.task print - -main :: IO () -main = - runSchedule_ $ - schedule SDL.setup - >>> schedule setup - >>> forever (schedule SDL.update >>> schedule update >>> schedule SDL.draw) diff --git a/examples/Window.hs b/examples/Window.hs deleted file mode 100644 --- a/examples/Window.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE Arrows #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeApplications #-} - -module Main where - -import Control.Arrow ((>>>)) -import Data.Aztecs -import qualified Data.Aztecs.Access as A -import Data.Aztecs.SDL (Window (..)) -import qualified Data.Aztecs.SDL as SDL -import qualified Data.Aztecs.System as S - -setup :: System () () -setup = S.queue . const . A.spawn_ $ bundle Window {windowTitle = "Aztecs"} - -main :: IO () -main = - runSchedule_ $ - schedule SDL.setup - >>> schedule setup - >>> forever (schedule SDL.update >>> schedule SDL.draw) diff --git a/src/Aztecs/SDL.hs b/src/Aztecs/SDL.hs new file mode 100644 --- /dev/null +++ b/src/Aztecs/SDL.hs @@ -0,0 +1,605 @@ +{-# LANGUAGE Arrows #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Aztecs.SDL + ( -- * Window components + WindowRenderer (..), + + -- * Camera components + Camera (..), + CameraTarget (..), + + -- * Surface components + Surface (..), + SurfaceTarget (..), + SurfaceTexture (..), + + -- * Input + + -- ** Keyboard input + fromSDLKeycode, + toSDLKeycode, + + -- ** Mouse input + mouseButtonFromSDL, + mouseButtonToSDL, + motionFromSDL, + motionToSDL, + + -- * Systems + setup, + update, + draw, + + -- ** Primitive systems + addWindows, + buildTextures, + addSurfaceTargets, + handleInput, + updateTime, + ) +where + +import Aztecs.Camera (Camera (..), CameraTarget (..), addCameraTargets) +import Aztecs.ECS +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 qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe, mapMaybe) +import qualified Data.Text as T +import GHC.Generics (Generic) +import SDL hiding (InputMotion (..), MouseButton (..), Surface, Texture, Window, windowTitle) +import qualified SDL + +#if !MIN_VERSION_base(4,20,0) +import Data.Foldable (foldl') +#endif + +-- | Window renderer component. +data WindowRenderer = WindowRenderer + { -- | SDL window. + windowRendererRaw :: !SDL.Window, + -- | SDL renderer. + windowRenderer :: !Renderer + } + deriving (Show, Generic) + +instance Component WindowRenderer + +instance NFData WindowRenderer where + rnf = rwhnf + +-- | Setup SDL +setup :: Schedule IO () () +setup = + fmap (const ()) $ + task (const initializeAll) + &&& system + ( S.queue + ( const $ do + A.spawn_ . bundle $ Time 0 + A.spawn_ $ bundle keyboardInput + A.spawn_ $ bundle mouseInput + ) + ) + +-- | Update SDL windows +update :: Schedule IO () () +update = + updateTime + >>> addWindows + >>> system (addCameraTargets >>> addSurfaceTargets) + >>> buildTextures + >>> handleInput + +-- | Setup new windows. +addWindows :: Schedule IO () () +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' + where + createWindowRenderer (eId, window) = do + sdlWindow <- createWindow (T.pack $ windowTitle window) defaultWindow + renderer <- createRenderer sdlWindow (-1) defaultRenderer + return (eId, sdlWindow, renderer) + insertWindowRenderer (eId, window, renderer) = A.insert eId (WindowRenderer window renderer) + +-- | Surface texture component. +newtype SurfaceTexture = SurfaceTexture + { -- | SDL texture. + unSurfaceTexture :: SDL.Texture + } + deriving (Generic) + +instance Component SurfaceTexture + +instance NFData SurfaceTexture where + rnf = rwhnf + +allWindowTextures :: + (ArrowQueryReader q, ArrowReaderSystem q arr, Applicative (q ())) => + arr () [(WindowRenderer, [(EntityID, Surface, Transform, Maybe SurfaceTexture)])] +allWindowTextures = + allWindowDraws + (pure ()) + ( proc () -> do + e <- Q.entity -< () + surface <- Q.fetch -< () + transform <- Q.fetch -< () + texture <- Q.fetchMaybe -< () + returnA -< (e, surface, transform, texture) + ) + >>> arr (\cs -> map (\(w, cs') -> (w, concatMap snd cs')) cs) + +-- | Build textures from surfaces in preparation for `drawTextures`. +buildTextures :: Schedule IO () () +buildTextures = + let go windowDraws = + mapM_ + ( \(window, cameraDraws) -> do + let renderer = windowRenderer window + mapM_ + ( \(eId, surface, transform, maybeTexture) -> do + sdlTexture <- SDL.createTextureFromSurface renderer $ sdlSurface surface + textureDesc <- queryTexture sdlTexture + case maybeTexture of + Just (SurfaceTexture lastTexture) -> destroyTexture lastTexture + Nothing -> return () + A.insert eId (SurfaceTexture sdlTexture) + A.insert + eId + ( Size $ + transformScale transform + * fromMaybe + (fmap fromIntegral $ V2 (textureWidth textureDesc) (textureHeight textureDesc)) + ((fmap (\(Rectangle _ s) -> fmap fromIntegral s) $ surfaceBounds surface)) + ) + ) + cameraDraws + ) + windowDraws + in reader allWindowTextures >>> access go + +draw :: Schedule IO () () +draw = + let go windowDraws = + mapM_ + ( \(window, cameraDraws) -> do + mapM_ + ( \((camera, cameraTransform), cameraDraws') -> do + let renderer = windowRenderer window + rendererDrawColor renderer $= V4 0 0 0 255 + rendererScale renderer $= fmap realToFrac (cameraScale camera) + rendererViewport renderer + $= Just + ( Rectangle + (P (fmap fromIntegral $ transformPosition cameraTransform)) + (fmap fromIntegral $ cameraViewport camera) + ) + clear renderer + mapM_ + ( \(surface, transform, texture) -> do + textureDesc <- queryTexture $ unSurfaceTexture texture + copyEx + renderer + (unSurfaceTexture texture) + (fmap fromIntegral <$> surfaceBounds surface) + ( Just + ( Rectangle + (fmap fromIntegral . P $ transformPosition transform) + ( fromMaybe + (fmap fromIntegral $ V2 (textureWidth textureDesc) (textureHeight textureDesc)) + ((fmap (\(Rectangle _ s) -> fmap fromIntegral s) $ surfaceBounds surface)) + ) + ) + ) + (realToFrac $ transformRotation transform) + Nothing + (V2 False False) + ) + cameraDraws' + present renderer + ) + cameraDraws + ) + windowDraws + in reader allCameraSurfaces >>> access go + +allCameraSurfaces :: + (ArrowQueryReader q, ArrowReaderSystem q arr) => + arr () [(WindowRenderer, [((Camera, Transform), [(Surface, Transform, SurfaceTexture)])])] +allCameraSurfaces = + allWindowDraws + (Q.fetch &&& Q.fetch) + ( proc () -> do + surface <- Q.fetch -< () + transform <- Q.fetch -< () + texture <- Q.fetch -< () + returnA -< (surface, transform, texture) + ) + +allWindowDraws :: + (ArrowQueryReader q, ArrowReaderSystem q arr) => + (q () a) -> + (q () b) -> + arr () [(WindowRenderer, [(a, [b])])] +allWindowDraws qA qB = proc () -> do + cameras <- + S.all + ( proc () -> do + eId <- Q.entity -< () + cameraTarget <- Q.fetch @_ @CameraTarget -< () + a <- qA -< () + returnA -< (eId, cameraTarget, a) + ) + -< + () + windows <- S.all (Q.entity &&& Q.fetch @_ @WindowRenderer) -< () + draws <- + S.all + ( proc () -> do + t <- Q.fetch @_ @SurfaceTarget -< () + a <- qB -< () + returnA -< (t, a) + ) + -< + () + let cameraDraws = + map + ( \(eId, cameraTarget, b) -> + ( cameraTarget, + b, + mapMaybe + ( \(surfaceTarget, a) -> + if drawTargetCamera surfaceTarget == eId + then Just a + else Nothing + ) + draws + ) + ) + cameras + windowDraws = + map + ( \(eId, window) -> + ( window, + map (\(_, a, b) -> (a, b)) $ + filter (\(cameraTarget, _, _) -> cameraTargetWindow cameraTarget == eId) cameraDraws + ) + ) + windows + returnA -< windowDraws + +-- | Surface target component. +-- This component can be used to specify which `Camera` to draw a `Surface` to. +newtype SurfaceTarget = SurfaceTarget {drawTargetCamera :: EntityID} + deriving (Eq, Show, Generic, NFData) + +instance Component SurfaceTarget + +-- | Surface component. +-- This component can be used to draw to a window. +data Surface = Surface + { sdlSurface :: !SDL.Surface, + surfaceBounds :: !(Maybe (Rectangle Int)) + } + +instance Component Surface + +instance NFData Surface where + rnf = rwhnf + +-- | Add `SurfaceTarget` components to entities with a new `Surface` component. +addSurfaceTargets :: System () () +addSurfaceTargets = proc () -> do + cameras <- S.all (Q.entity &&& Q.fetch @_ @Camera) -< () + newDraws <- S.filter (Q.entity &&& Q.fetch @_ @Surface) (without @SurfaceTarget) -< () + S.queue + ( \(newDraws, cameras) -> case cameras of + (cameraEId, _) : _ -> mapM_ (\(eId, _) -> A.insert eId $ SurfaceTarget cameraEId) newDraws + _ -> return () + ) + -< + (newDraws, cameras) + +updateTime :: Schedule IO () () +updateTime = proc () -> do + t <- task (const SDL.ticks) -< () + system $ S.mapSingle Q.set -< Time t + returnA -< () + +handleInput :: Schedule IO () () +handleInput = task (const pollEvents) >>> system handleInput' + +-- | Keyboard input system. +handleInput' :: System [Event] () +handleInput' = proc events -> do + kb <- S.single Q.fetch -< () + mouse <- S.single Q.fetch -< () + let go (kbAcc, mouseAcc) event = case eventPayload event of + KeyboardEvent keyboardEvent -> + ( case fromSDLKeycode $ keysymKeycode $ keyboardEventKeysym keyboardEvent of + Just key -> handleKeyboardEvent key (motionFromSDL $ keyboardEventKeyMotion keyboardEvent) kbAcc + Nothing -> kbAcc, + mouseAcc + ) + MouseMotionEvent mouseMotionEvent -> + ( kbAcc, + mouseAcc + { mousePosition = (fmap fromIntegral $ mouseMotionEventPos mouseMotionEvent), + mouseOffset = (fmap fromIntegral $ mouseMotionEventRelMotion mouseMotionEvent), + mouseButtons = (mouseButtons mouseAcc) + } + ) + MouseButtonEvent mouseButtonEvent -> + ( kbAcc, + mouseAcc + { mousePosition = (fmap fromIntegral $ mouseButtonEventPos mouseButtonEvent), + mouseButtons = + Map.insert + (mouseButtonFromSDL $ mouseButtonEventButton mouseButtonEvent) + (motionFromSDL $ mouseButtonEventMotion mouseButtonEvent) + (mouseButtons mouseAcc) + } + ) + _ -> (kbAcc, mouseAcc) + (kb', mouseInput') = foldl' go (kb {keyboardEvents = mempty}, mouse {mouseOffset = V2 0 0}) events + S.mapSingle Q.set -< kb' + S.mapSingle Q.set -< mouseInput' + returnA -< () + +mouseButtonFromSDL :: SDL.MouseButton -> MouseButton +mouseButtonFromSDL b = case b of + SDL.ButtonLeft -> ButtonLeft + SDL.ButtonMiddle -> ButtonMiddle + SDL.ButtonRight -> ButtonRight + SDL.ButtonX1 -> ButtonX1 + SDL.ButtonX2 -> ButtonX2 + SDL.ButtonExtra i -> ButtonExtra i + +mouseButtonToSDL :: MouseButton -> SDL.MouseButton +mouseButtonToSDL b = case b of + ButtonLeft -> SDL.ButtonLeft + ButtonMiddle -> SDL.ButtonMiddle + ButtonRight -> SDL.ButtonRight + ButtonX1 -> SDL.ButtonX1 + ButtonX2 -> SDL.ButtonX2 + ButtonExtra i -> SDL.ButtonExtra i + +motionFromSDL :: SDL.InputMotion -> InputMotion +motionFromSDL m = case m of + SDL.Pressed -> Pressed + SDL.Released -> Released + +motionToSDL :: InputMotion -> SDL.InputMotion +motionToSDL m = case m of + Pressed -> SDL.Pressed + Released -> SDL.Released + +toSDLKeycode :: Key -> SDL.Keycode +toSDLKeycode key = case key of + KeyA -> SDL.KeycodeA + KeyB -> SDL.KeycodeB + KeyC -> SDL.KeycodeC + KeyD -> SDL.KeycodeD + KeyE -> SDL.KeycodeE + KeyF -> SDL.KeycodeF + KeyG -> SDL.KeycodeG + KeyH -> SDL.KeycodeH + KeyI -> SDL.KeycodeI + KeyJ -> SDL.KeycodeJ + KeyK -> SDL.KeycodeK + KeyL -> SDL.KeycodeL + KeyM -> SDL.KeycodeM + KeyN -> SDL.KeycodeN + KeyO -> SDL.KeycodeO + KeyP -> SDL.KeycodeP + KeyQ -> SDL.KeycodeQ + KeyR -> SDL.KeycodeR + KeyS -> SDL.KeycodeS + KeyT -> SDL.KeycodeT + KeyU -> SDL.KeycodeU + KeyV -> SDL.KeycodeV + KeyW -> SDL.KeycodeW + KeyX -> SDL.KeycodeX + KeyY -> SDL.KeycodeY + KeyZ -> SDL.KeycodeZ + Key0 -> SDL.Keycode0 + Key1 -> SDL.Keycode1 + Key2 -> SDL.Keycode2 + Key3 -> SDL.Keycode3 + Key4 -> SDL.Keycode4 + Key5 -> SDL.Keycode5 + Key6 -> SDL.Keycode6 + Key7 -> SDL.Keycode7 + Key8 -> SDL.Keycode8 + Key9 -> SDL.Keycode9 + KeyF1 -> SDL.KeycodeF1 + KeyF2 -> SDL.KeycodeF2 + KeyF3 -> SDL.KeycodeF3 + KeyF4 -> SDL.KeycodeF4 + KeyF5 -> SDL.KeycodeF5 + KeyF6 -> SDL.KeycodeF6 + KeyF7 -> SDL.KeycodeF7 + KeyF8 -> SDL.KeycodeF8 + KeyF9 -> SDL.KeycodeF9 + KeyF10 -> SDL.KeycodeF10 + KeyF11 -> SDL.KeycodeF11 + KeyF12 -> SDL.KeycodeF12 + KeyEscape -> SDL.KeycodeEscape + KeyEnter -> SDL.KeycodeReturn + KeySpace -> SDL.KeycodeSpace + KeyBackspace -> SDL.KeycodeBackspace + KeyTab -> SDL.KeycodeTab + KeyCapsLock -> SDL.KeycodeCapsLock + KeyShift -> SDL.KeycodeLShift + KeyCtrl -> SDL.KeycodeLCtrl + KeyAlt -> SDL.KeycodeLAlt + KeyLeft -> SDL.KeycodeLeft + KeyRight -> SDL.KeycodeRight + KeyUp -> SDL.KeycodeUp + KeyDown -> SDL.KeycodeDown + KeyHome -> SDL.KeycodeHome + KeyEnd -> SDL.KeycodeEnd + KeyPageUp -> SDL.KeycodePageUp + KeyPageDown -> SDL.KeycodePageDown + KeyInsert -> SDL.KeycodeInsert + KeyDelete -> SDL.KeycodeDelete + KeyMinus -> SDL.KeycodeMinus + KeyEquals -> SDL.KeycodeEquals + KeyBracketLeft -> SDL.KeycodeLeftBracket + KeyBracketRight -> SDL.KeycodeRightBracket + KeyBackslash -> SDL.KeycodeBackslash + KeySemicolon -> SDL.KeycodeSemicolon + KeyComma -> SDL.KeycodeComma + KeyPeriod -> SDL.KeycodePeriod + KeySlash -> SDL.KeycodeSlash + KeyNumLock -> SDL.KeycodeNumLockClear + KeyNumpad0 -> SDL.KeycodeKP0 + KeyNumpad1 -> SDL.KeycodeKP1 + KeyNumpad2 -> SDL.KeycodeKP2 + KeyNumpad3 -> SDL.KeycodeKP3 + KeyNumpad4 -> SDL.KeycodeKP4 + KeyNumpad5 -> SDL.KeycodeKP5 + KeyNumpad6 -> SDL.KeycodeKP6 + KeyNumpad7 -> SDL.KeycodeKP7 + KeyNumpad8 -> SDL.KeycodeKP8 + KeyNumpad9 -> SDL.KeycodeKP9 + KeyNumpadDivide -> SDL.KeycodeKPDivide + KeyNumpadMultiply -> SDL.KeycodeKPMultiply + KeyNumpadMinus -> SDL.KeycodeKPMinus + KeyNumpadPlus -> SDL.KeycodeKPPlus + KeyNumpadEnter -> SDL.KeycodeKPEnter + KeyNumpadPeriod -> SDL.KeycodeKPPeriod + KeySuper -> SDL.KeycodeLGUI -- assuming left Super (Windows/Command key); SDL also has RGUI + KeyMenu -> SDL.KeycodeMenu + +fromSDLKeycode :: SDL.Keycode -> Maybe Key +fromSDLKeycode keycode = case keycode of + SDL.KeycodeA -> Just KeyA + SDL.KeycodeB -> Just KeyB + SDL.KeycodeC -> Just KeyC + SDL.KeycodeD -> Just KeyD + SDL.KeycodeE -> Just KeyE + SDL.KeycodeF -> Just KeyF + SDL.KeycodeG -> Just KeyG + SDL.KeycodeH -> Just KeyH + SDL.KeycodeI -> Just KeyI + SDL.KeycodeJ -> Just KeyJ + SDL.KeycodeK -> Just KeyK + SDL.KeycodeL -> Just KeyL + SDL.KeycodeM -> Just KeyM + SDL.KeycodeN -> Just KeyN + SDL.KeycodeO -> Just KeyO + SDL.KeycodeP -> Just KeyP + SDL.KeycodeQ -> Just KeyQ + SDL.KeycodeR -> Just KeyR + SDL.KeycodeS -> Just KeyS + SDL.KeycodeT -> Just KeyT + SDL.KeycodeU -> Just KeyU + SDL.KeycodeV -> Just KeyV + SDL.KeycodeW -> Just KeyW + SDL.KeycodeX -> Just KeyX + SDL.KeycodeY -> Just KeyY + SDL.KeycodeZ -> Just KeyZ + SDL.Keycode0 -> Just Key0 + SDL.Keycode1 -> Just Key1 + SDL.Keycode2 -> Just Key2 + SDL.Keycode3 -> Just Key3 + SDL.Keycode4 -> Just Key4 + SDL.Keycode5 -> Just Key5 + SDL.Keycode6 -> Just Key6 + SDL.Keycode7 -> Just Key7 + SDL.Keycode8 -> Just Key8 + SDL.Keycode9 -> Just Key9 + SDL.KeycodeF1 -> Just KeyF1 + SDL.KeycodeF2 -> Just KeyF2 + SDL.KeycodeF3 -> Just KeyF3 + SDL.KeycodeF4 -> Just KeyF4 + SDL.KeycodeF5 -> Just KeyF5 + SDL.KeycodeF6 -> Just KeyF6 + SDL.KeycodeF7 -> Just KeyF7 + SDL.KeycodeF8 -> Just KeyF8 + SDL.KeycodeF9 -> Just KeyF9 + SDL.KeycodeF10 -> Just KeyF10 + SDL.KeycodeF11 -> Just KeyF11 + SDL.KeycodeF12 -> Just KeyF12 + SDL.KeycodeEscape -> Just KeyEscape + SDL.KeycodeReturn -> Just KeyEnter + SDL.KeycodeSpace -> Just KeySpace + SDL.KeycodeBackspace -> Just KeyBackspace + SDL.KeycodeTab -> Just KeyTab + SDL.KeycodeCapsLock -> Just KeyCapsLock + SDL.KeycodeLShift -> Just KeyShift + SDL.KeycodeRShift -> Just KeyShift + SDL.KeycodeLCtrl -> Just KeyCtrl + SDL.KeycodeRCtrl -> Just KeyCtrl + SDL.KeycodeLAlt -> Just KeyAlt + SDL.KeycodeRAlt -> Just KeyAlt + SDL.KeycodeLeft -> Just KeyLeft + SDL.KeycodeRight -> Just KeyRight + SDL.KeycodeUp -> Just KeyUp + SDL.KeycodeDown -> Just KeyDown + SDL.KeycodeHome -> Just KeyHome + SDL.KeycodeEnd -> Just KeyEnd + SDL.KeycodePageUp -> Just KeyPageUp + SDL.KeycodePageDown -> Just KeyPageDown + SDL.KeycodeInsert -> Just KeyInsert + SDL.KeycodeDelete -> Just KeyDelete + SDL.KeycodeMinus -> Just KeyMinus + SDL.KeycodeEquals -> Just KeyEquals + SDL.KeycodeLeftBracket -> Just KeyBracketLeft + SDL.KeycodeRightBracket -> Just KeyBracketRight + SDL.KeycodeBackslash -> Just KeyBackslash + SDL.KeycodeSemicolon -> Just KeySemicolon + SDL.KeycodeComma -> Just KeyComma + SDL.KeycodePeriod -> Just KeyPeriod + SDL.KeycodeSlash -> Just KeySlash + SDL.KeycodeNumLockClear -> Just KeyNumLock + SDL.KeycodeKP0 -> Just KeyNumpad0 + SDL.KeycodeKP1 -> Just KeyNumpad1 + SDL.KeycodeKP2 -> Just KeyNumpad2 + SDL.KeycodeKP3 -> Just KeyNumpad3 + SDL.KeycodeKP4 -> Just KeyNumpad4 + SDL.KeycodeKP5 -> Just KeyNumpad5 + SDL.KeycodeKP6 -> Just KeyNumpad6 + SDL.KeycodeKP7 -> Just KeyNumpad7 + SDL.KeycodeKP8 -> Just KeyNumpad8 + SDL.KeycodeKP9 -> Just KeyNumpad9 + SDL.KeycodeKPDivide -> Just KeyNumpadDivide + SDL.KeycodeKPMultiply -> Just KeyNumpadMultiply + SDL.KeycodeKPMinus -> Just KeyNumpadMinus + SDL.KeycodeKPPlus -> Just KeyNumpadPlus + SDL.KeycodeKPEnter -> Just KeyNumpadEnter + SDL.KeycodeKPPeriod -> Just KeyNumpadPeriod + SDL.KeycodeLGUI -> Just KeySuper + SDL.KeycodeRGUI -> Just KeySuper + SDL.KeycodeMenu -> Just KeyMenu + _ -> Nothing diff --git a/src/Data/Aztecs/SDL.hs b/src/Data/Aztecs/SDL.hs deleted file mode 100644 --- a/src/Data/Aztecs/SDL.hs +++ /dev/null @@ -1,478 +0,0 @@ -{-# LANGUAGE Arrows #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} - -module Data.Aztecs.SDL - ( -- * Window components - Window (..), - WindowRenderer (..), - - -- * Camera components - Camera (..), - CameraTarget (..), - - -- * Surface components - Surface (..), - SurfaceTarget (..), - SurfaceTexture (..), - - -- * Input - - -- ** Keyboard input - KeyboardInput (..), - isKeyPressed, - wasKeyPressed, - wasKeyReleased, - - -- ** Mouse input - MouseInput (..), - - -- * Time - Time (..), - - -- * Systems - setup, - update, - draw, - - -- ** Primitive systems - addWindows, - buildTextures, - drawTextures, - addCameraTargets, - addSurfaceTargets, - handleInput, - updateTime, - clearKeyboard, - clearKeyboardQuery, - clearMouseInput, - clearMouseInputQuery, - ) -where - -import Control.Arrow (Arrow (..), returnA, (>>>)) -import Data.Aztecs -import qualified Data.Aztecs.Access as A -import qualified Data.Aztecs.Query as Q -import qualified Data.Aztecs.System as S -import Data.Aztecs.Transform (Size (..), Transform (..)) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe, mapMaybe) -import Data.Set (Set) -import qualified Data.Set as Set -import qualified Data.Text as T -import Data.Word (Word32) -import SDL hiding (Surface, Texture, Window, windowTitle) -import qualified SDL - -#if !MIN_VERSION_base(4,20,0) -import Data.Foldable (foldl') -#endif - --- | 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 - -data Camera = Camera {cameraViewport :: !(V2 Int), cameraScale :: !(V2 Float)} - deriving (Show) - -instance Component Camera - -newtype CameraTarget = CameraTarget {cameraTargetWindow :: EntityID} - deriving (Eq, Show) - -instance Component CameraTarget - --- | Setup SDL -setup :: System () () -setup = - fmap (const ()) $ - S.task (const initializeAll) - &&& S.queue - ( const $ do - A.spawn_ . bundle $ Time 0 - A.spawn_ . bundle $ KeyboardInput mempty mempty - A.spawn_ . bundle $ MouseInput (P $ V2 0 0) (V2 0 0) mempty - ) - --- | Update SDL windows -update :: System () () -update = - const () - <$> ( updateTime - &&& ( addWindows - >>> addCameraTargets - >>> addSurfaceTargets - >>> handleInput - >>> buildTextures - ) - ) - -draw :: System () () -draw = const () <$> (drawTextures &&& clearKeyboard &&& clearMouseInput) - --- | Setup new windows. -addWindows :: System () () -addWindows = proc () -> do - newWindows <- S.filter (Q.entity &&& Q.fetch @_ @Window) (without @WindowRenderer) -< () - newWindows' <- S.task 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) - -newtype SurfaceTexture = SurfaceTexture {unSurfaceTexture :: SDL.Texture} - -instance Component SurfaceTexture - -buildTextures :: System () () -buildTextures = - let go windowDraws = - mapM_ - ( \(window, cameraDraws) -> do - mapM_ - ( \(_, cameraDraws') -> do - let renderer = windowRenderer window - mapM_ - ( \(eId, surface, transform, maybeTexture) -> do - sdlTexture <- SDL.createTextureFromSurface renderer $ sdlSurface surface - textureDesc <- queryTexture sdlTexture - case maybeTexture of - Just (SurfaceTexture lastTexture) -> destroyTexture lastTexture - Nothing -> return () - A.insert eId (SurfaceTexture sdlTexture) - A.insert - eId - ( Size $ - transformScale transform - * fromMaybe - (fmap fromIntegral $ V2 (textureWidth textureDesc) (textureHeight textureDesc)) - ((fmap (\(Rectangle _ s) -> fmap fromIntegral s) $ surfaceBounds surface)) - ) - ) - cameraDraws' - ) - cameraDraws - ) - windowDraws - in proc () -> do - cameras <- S.all $ Q.entity &&& Q.fetch -< () - windows <- S.all (Q.entity &&& Q.fetch @_ @WindowRenderer) -< () - draws <- - S.all - ( proc () -> do - eId <- Q.entity -< () - d <- Q.fetch @_ @Surface -< () - transform <- Q.fetch @_ @Transform -< () - target <- Q.fetch @_ @SurfaceTarget -< () - maybeTexture <- Q.fetchMaybe @_ @SurfaceTexture -< () - returnA -< (eId, d, transform, target, maybeTexture) - ) - -< - () - let cameraDraws = - map - ( \(eId, cameraTarget) -> - ( cameraTarget, - mapMaybe - ( \(surfaceEid, d, transform, target, maybeTexture) -> - if drawTargetCamera target == eId - then Just (surfaceEid, d, transform, maybeTexture) - else Nothing - ) - draws - ) - ) - cameras - windowDraws = - map - ( \(eId, window) -> - ( window, - filter (\(cameraTarget, _) -> cameraTargetWindow cameraTarget == eId) cameraDraws - ) - ) - windows - S.queue go -< windowDraws - -drawTextures :: System () () -drawTextures = - let go windowDraws = - mapM_ - ( \(window, cameraDraws) -> do - mapM_ - ( \(camera, _, cameraTransform, cameraDraws') -> do - let renderer = windowRenderer window - rendererDrawColor renderer $= V4 0 0 0 255 - rendererScale renderer $= fmap realToFrac (cameraScale camera) - rendererViewport renderer - $= Just - ( Rectangle - (P (fmap fromIntegral $ transformPosition cameraTransform)) - (fmap fromIntegral $ cameraViewport camera) - ) - clear renderer - mapM_ - ( \(surface, transform, texture) -> do - textureDesc <- queryTexture $ unSurfaceTexture texture - copyEx - renderer - (unSurfaceTexture texture) - (fmap fromIntegral <$> surfaceBounds surface) - ( Just - ( Rectangle - (fmap fromIntegral . P $ transformPosition transform) - ( fromMaybe - (fmap fromIntegral $ V2 (textureWidth textureDesc) (textureHeight textureDesc)) - ((fmap (\(Rectangle _ s) -> fmap fromIntegral s) $ surfaceBounds surface)) - ) - ) - ) - (realToFrac $ transformRotation transform) - Nothing - (V2 False False) - ) - cameraDraws' - present renderer - ) - cameraDraws - ) - windowDraws - in proc () -> do - cameras <- - S.all - ( proc () -> do - eId <- Q.entity -< () - camera <- Q.fetch @_ @Camera -< () - cameraTarget <- Q.fetch @_ @CameraTarget -< () - t <- Q.fetch @_ @Transform -< () - returnA -< (eId, camera, cameraTarget, t) - ) - -< - () - windows <- S.all (Q.entity &&& Q.fetch @_ @WindowRenderer) -< () - draws <- - S.all - ( proc () -> do - d <- Q.fetch @_ @Surface -< () - transform <- Q.fetch @_ @Transform -< () - target <- Q.fetch @_ @SurfaceTarget -< () - texture <- Q.fetch @_ @SurfaceTexture -< () - returnA -< (d, transform, target, texture) - ) - -< - () - let cameraDraws = - map - ( \(eId, camera, cameraTarget, t) -> - ( camera, - cameraTarget, - t, - mapMaybe - ( \(d, transform, target, texture) -> - if drawTargetCamera target == eId - then Just (d, transform, texture) - else Nothing - ) - draws - ) - ) - cameras - windowDraws = - map - ( \(eId, window) -> - ( window, - filter (\(_, cameraTarget, _, _) -> cameraTargetWindow cameraTarget == eId) cameraDraws - ) - ) - windows - S.task go -< windowDraws - --- | Surface target component. --- This component can be used to specify which `Camera` to draw a `Surface` to. -newtype SurfaceTarget = SurfaceTarget {drawTargetCamera :: EntityID} - deriving (Eq, Show) - -instance Component SurfaceTarget - --- | Surface component. --- This component can be used to draw to a window. -data Surface = Surface - { sdlSurface :: !SDL.Surface, - surfaceBounds :: !(Maybe (Rectangle Int)) - } - -instance Component Surface - --- | Add `CameraTarget` components to entities with a new `Draw` component. -addCameraTargets :: System () () -addCameraTargets = proc () -> do - windows <- S.all (Q.entity &&& Q.fetch @_ @Window) -< () - newCameras <- S.filter (Q.entity &&& Q.fetch @_ @Camera) (without @CameraTarget) -< () - S.queue - ( \(newCameras, windows) -> case windows of - (windowEId, _) : _ -> mapM_ (\(eId, _) -> A.insert eId $ CameraTarget windowEId) newCameras - _ -> return () - ) - -< - (newCameras, windows) - --- | Add `SurfaceTarget` components to entities with a new `Surface` component. -addSurfaceTargets :: System () () -addSurfaceTargets = proc () -> do - cameras <- S.all (Q.entity &&& Q.fetch @_ @Camera) -< () - newDraws <- S.filter (Q.entity &&& Q.fetch @_ @Surface) (without @SurfaceTarget) -< () - S.queue - ( \(newDraws, cameras) -> case cameras of - (cameraEId, _) : _ -> mapM_ (\(eId, _) -> A.insert eId $ SurfaceTarget cameraEId) newDraws - _ -> return () - ) - -< - (newDraws, cameras) - -newtype Time = Time {elapsedMS :: Word32} - deriving (Eq, Ord, Num, Show) - -instance Component Time - -updateTime :: System () () -updateTime = proc () -> do - t <- S.task (const SDL.ticks) -< () - S.mapSingle Q.set -< Time t - returnA -< () - --- | Keyboard input component. -data KeyboardInput = KeyboardInput - { -- | Keyboard events that occured this frame. - keyboardEvents :: !(Map Keycode InputMotion), - -- | Keys that are currently pressed. - keyboardPressed :: !(Set Keycode) - } - deriving (Show) - -instance Component KeyboardInput - --- | @True@ if this key is currently pressed. -isKeyPressed :: Keycode -> KeyboardInput -> Bool -isKeyPressed key kb = Set.member key $ keyboardPressed kb - --- | Check for a key event that occured this frame. -keyEvent :: Keycode -> KeyboardInput -> Maybe InputMotion -keyEvent key kb = Map.lookup key $ keyboardEvents kb - --- | @True@ if this key was pressed this frame. -wasKeyPressed :: Keycode -> KeyboardInput -> Bool -wasKeyPressed key kb = case keyEvent key kb of - Just Pressed -> True - _ -> False - --- | @True@ if this key was released this frame. -wasKeyReleased :: Keycode -> KeyboardInput -> Bool -wasKeyReleased key kb = case keyEvent key kb of - Just Released -> True - _ -> False - --- | Mouse input component. -data MouseInput = MouseInput - { -- | Mouse position in screen-space. - mousePosition :: !(Point V2 Int), - -- | Mouse offset since last frame. - mouseOffset :: !(V2 Int), - -- | Mouse button states. - mouseButtons :: !(Map MouseButton InputMotion) - } - deriving (Show) - -instance Component MouseInput - --- | Keyboard input system. -handleInput :: System () () -handleInput = proc () -> do - events <- S.task . const $ SDL.pollEvents -< () - kb <- S.single Q.fetch -< () - mouseInput <- S.single Q.fetch -< () - let go (kbAcc, mouseAcc) event = case eventPayload event of - KeyboardEvent keyboardEvent -> - ( KeyboardInput - ( Map.insert - (keysymKeycode $ keyboardEventKeysym keyboardEvent) - (keyboardEventKeyMotion keyboardEvent) - (keyboardEvents kbAcc) - ) - ( case keyboardEventKeyMotion keyboardEvent of - Pressed -> - Set.insert - (keysymKeycode $ keyboardEventKeysym keyboardEvent) - (keyboardPressed kbAcc) - Released -> - Set.delete - (keysymKeycode $ keyboardEventKeysym keyboardEvent) - (keyboardPressed kbAcc) - ), - mouseAcc - ) - MouseMotionEvent mouseMotionEvent -> - ( kbAcc, - MouseInput - { mousePosition = (fmap fromIntegral $ mouseMotionEventPos mouseMotionEvent), - mouseOffset = (fmap fromIntegral $ mouseMotionEventRelMotion mouseMotionEvent), - mouseButtons = (mouseButtons mouseAcc) - } - ) - MouseButtonEvent mouseButtonEvent -> - ( kbAcc, - MouseInput - { mousePosition = (fmap fromIntegral $ mouseButtonEventPos mouseButtonEvent), - mouseOffset = V2 0 0, - mouseButtons = - Map.insert - (mouseButtonEventButton mouseButtonEvent) - (mouseButtonEventMotion mouseButtonEvent) - (mouseButtons mouseAcc) - } - ) - _ -> (kbAcc, mouseAcc) - (kb', mouseInput') = foldl' go (kb, mouseInput) events - S.mapSingle Q.set -< kb' - S.mapSingle Q.set -< mouseInput' - returnA -< () - -clearKeyboardQuery :: (Monad m) => Query m () KeyboardInput -clearKeyboardQuery = proc () -> do - kb <- Q.fetch -< () - Q.set -< kb {keyboardEvents = mempty} - -clearKeyboard :: System () () -clearKeyboard = const () <$> S.mapSingle clearKeyboardQuery - -clearMouseInputQuery :: (Monad m) => Query m () MouseInput -clearMouseInputQuery = proc () -> do - mouseInput <- Q.fetch -< () - Q.set -< mouseInput {mouseButtons = mempty, mouseOffset = V2 0 0} - -clearMouseInput :: System () () -clearMouseInput = const () <$> S.mapSingle clearMouseInputQuery