diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for affection + +## 0.0.0.7 -- 2017-12-23 + +* Release with working scaffold for engine subsystems. diff --git a/affection.cabal b/affection.cabal --- a/affection.cabal +++ b/affection.cabal @@ -6,10 +6,10 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.0.0.6 +version: 0.0.0.7 synopsis: A simple Game Engine using SDL description: This package contains Affection, a simple game engine - written in Haskell using SDL and GEGL. + written in Haskell using SDL. This Engine is still work in progress and even minor version bumps may contain breaking api changes. homepage: https://github.com/nek0/affection#readme @@ -19,6 +19,7 @@ maintainer: nek0@chelnok.de category: Game build-type: Simple +extra-source-files: ChangeLog.md -- Extra files to be distributed with the package, such as examples or a -- README. @@ -30,19 +31,58 @@ type: git location: https://github.com/nek0/affection +flag verbose + description: Enable verbose debug messages + default: False + manual: True + +flag debug + description: Enable debug messages + default: False + manual: True + +flag warn + description: Enable warning messages + default: False + manual: True + +flag error + description: Enable error messages + default: False + manual: True + flag examples description: Build example programs default: False library + if flag(verbose) + cpp-options: -DVERBOSE + if flag(debug) + cpp-options: -DDEBUG + if flag(warn) + cpp-options: -DWARN + if flag(error) + cpp-options: -DERROR exposed-modules: Affection - , Affection.Draw - , Affection.Particle + , Affection.Logging , Affection.Types , Affection.StateMachine , Affection.MouseInteractable - , Affection.Property - , Affection.Actor + , Affection.Util + , Affection.MessageBus + , Affection.MessageBus.Util + , Affection.MessageBus.Class + , Affection.MessageBus.Message + , Affection.MessageBus.Message.Class + , Affection.MessageBus.Message.WindowMessage + , Affection.MessageBus.Message.KeyboardMessage + , Affection.MessageBus.Message.MouseMessage + , Affection.Subsystems + , Affection.Subsystems.Class + , Affection.Subsystems.AffectionWindow + , Affection.Subsystems.AffectionKeyboard + , Affection.Subsystems.AffectionMouse default-extensions: OverloadedStrings -- Modules included in this library but not exported. @@ -58,19 +98,23 @@ default-language: Haskell2010 ghc-options: -Wall -- Other library packages from which modules are imported. - build-depends: base >=4.9 && <4.10 + build-depends: base >=4.9 && < 5 , sdl2 + , linear , text , mtl - , gegl - , babl , monad-loops , monad-parallel , containers , clock , glib - -- , sdl2-image + , bytestring + , OpenGL + , stm + , uuid +-- This example shows the message system. only makes sense when compiling with +-- verbose flag. executable example00 hs-source-dirs: examples main-is: example00.hs @@ -78,85 +122,83 @@ default-language: Haskell2010 default-extensions: OverloadedStrings if flag(examples) - build-depends: base - , affection - , sdl2 - , gegl - , babl - , containers - , mtl - else - buildable: False - -executable example01 - hs-source-dirs: examples - main-is: example01.hs - ghc-options: -threaded -Wall - default-language: Haskell2010 - default-extensions: OverloadedStrings - if flag(examples) - build-depends: base - , affection - , sdl2 - , gegl - , babl - , containers - , mtl - else - buildable: False - -executable example02 - hs-source-dirs: examples - main-is: example02.hs - ghc-options: -threaded -Wall - default-language: Haskell2010 - default-extensions: OverloadedStrings - if flag(examples) - build-depends: base - , affection - , sdl2 - , gegl - , babl - , containers - , mtl - else - buildable: False - -executable example02.1 - hs-source-dirs: examples - main-is: example02.1.hs - ghc-options: -threaded -Wall - default-language: Haskell2010 - default-extensions: OverloadedStrings - if flag(examples) - build-depends: base - , affection - , sdl2 - , gegl - , babl - , containers - , mtl - else - buildable: False - -executable example03 - hs-source-dirs: examples - main-is: example03.hs - ghc-options: -threaded -Wall -auto-all -caf-all -rtsopts - default-language: Haskell2010 - default-extensions: OverloadedStrings - if flag(examples) - build-depends: base + build-depends: base >=4.9 && < 5 , affection , sdl2 - , gegl - , babl - , containers - , mtl - , random + , stm else buildable: False +-- executable example01 +-- hs-source-dirs: examples +-- main-is: example01.hs +-- ghc-options: -threaded -Wall +-- default-language: Haskell2010 +-- default-extensions: OverloadedStrings +-- if flag(examples) +-- build-depends: base +-- , affection +-- , sdl2 +-- , gegl +-- , babl +-- , containers +-- , mtl +-- else +-- buildable: False +-- +-- executable example02 +-- hs-source-dirs: examples +-- main-is: example02.hs +-- ghc-options: -threaded -Wall +-- default-language: Haskell2010 +-- default-extensions: OverloadedStrings +-- if flag(examples) +-- build-depends: base +-- , affection +-- , sdl2 +-- , gegl +-- , babl +-- , containers +-- , mtl +-- , monad-parallel +-- else +-- buildable: False +-- +-- executable example02.1 +-- hs-source-dirs: examples +-- main-is: example02.1.hs +-- ghc-options: -threaded -Wall +-- default-language: Haskell2010 +-- default-extensions: OverloadedStrings +-- if flag(examples) +-- build-depends: base +-- , affection +-- , sdl2 +-- , gegl +-- , babl +-- , containers +-- , mtl +-- else +-- buildable: False +-- +-- executable example03 +-- hs-source-dirs: examples +-- main-is: example03.hs +-- ghc-options: -threaded -Wall -auto-all -caf-all -rtsopts +-- default-language: Haskell2010 +-- default-extensions: OverloadedStrings +-- if flag(examples) +-- build-depends: base +-- , affection +-- , sdl2 +-- , gegl +-- , babl +-- , containers +-- , mtl +-- , random +-- else +-- buildable: False +-- -- executable example04 -- hs-source-dirs: examples -- main-is: example04.hs @@ -172,5 +214,29 @@ -- , containers -- , mtl -- , random +-- , monad-parallel +-- else +-- buildable: False +-- +-- executable example05 +-- hs-source-dirs: examples +-- main-is: example05.hs +-- ghc-options: -threaded -Wall -auto-all -caf-all -rtsopts +-- default-language: Haskell2010 +-- default-extensions: OverloadedStrings +-- if flag(examples) +-- build-depends: base +-- , affection +-- , sdl2 +-- , gegl +-- , babl +-- , containers +-- , unordered-containers +-- , mtl +-- , random +-- , matrix +-- , random +-- , monad-parallel +-- , parallel -- else -- buildable: False diff --git a/examples/example00.hs b/examples/example00.hs --- a/examples/example00.hs +++ b/examples/example00.hs @@ -1,117 +1,138 @@ -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE MultiParamTypeClasses #-} import Affection import qualified SDL -import qualified SDL.Raw as Raw -import qualified GEGL as G -import qualified BABL as B -import qualified Data.Map.Strict as M -import Control.Monad (when) +import Control.Concurrent.STM +import Control.Monad.IO.Class (liftIO) -import Foreign.Storable (peek) -import Foreign.C.Types (CInt(..)) +newtype StateData = StateData + { sdSubs :: Subsystems + } -import Debug.Trace +data Subsystems = Subsystems + { subWindow :: Window + , subMouse :: Mouse + , subKeyboard :: Keyboard + } --- main :: IO () --- main = withAllAffection $ --- withDefaultWindow "test" $ do --- changeColor $ RGBA 255 255 255 255 --- clear --- present --- liftIO $ delaySec 2 +newtype Window = Window (TVar [(UUID, WindowMessage -> Affection StateData ())]) +newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection StateData ())]) +newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection StateData ())]) +instance Participant Window WindowMessage StateData where + partSubscribers (Window t) = do + subTups <- liftIO $ readTVarIO t + return $ map snd subTups + + partSubscribe (Window t) funct = do + uuid <- genUUID + liftIO $ atomically $ modifyTVar' t ((uuid, funct) :) + return $ MsgId uuid MsgWindowEmptyEvent + + partUnSubscribe (Window t) (MsgId uuid _) = + liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid)) + +instance SDLSubsystem Window StateData where + consumeSDLEvents = consumeSDLWindowEvents + +instance Participant Mouse MouseMessage StateData where + partSubscribers (Mouse t) = do + subTups <- liftIO $ readTVarIO t + return $ map snd subTups + + partSubscribe (Mouse t) funct = do + uuid <- genUUID + liftIO $ atomically $ modifyTVar' t ((uuid, funct) :) + return $ MsgId uuid MsgMouseEmptyEvent + + partUnSubscribe (Mouse t) (MsgId uuid _) = + liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid)) + +instance SDLSubsystem Mouse StateData where + consumeSDLEvents = consumeSDLMouseEvents + +instance Participant Keyboard KeyboardMessage StateData where + partSubscribers (Keyboard t) = do + subTups <- liftIO $ readTVarIO t + return $ map snd subTups + + partSubscribe (Keyboard t) funct = do + uuid <- genUUID + liftIO $ atomically $ modifyTVar' t ((uuid, funct) :) + return $ MsgId uuid MsgKeyboardEmptyEvent + + partUnSubscribe (Keyboard t) (MsgId uuid _) = + liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid)) + +instance SDLSubsystem Keyboard StateData where + consumeSDLEvents = consumeSDLKeyboardEvents + main :: IO () main = do - conf <- return $ AffectionConfig - { initComponents = All - , windowTitle = "Affection: example00" - , windowConfig = SDL.defaultWindow - , preLoop = return () - , eventLoop = handle - , updateLoop = update - , drawLoop = draw - , loadState = load - , cleanUp = clean - } + logIO Debug "Starting" + let conf = AffectionConfig + { initComponents = All + , windowTitle = "affection: example00" + , windowConfig = SDL.defaultWindow + { SDL.windowOpenGL = Just SDL.defaultOpenGL + { SDL.glProfile = SDL.Core SDL.Normal 3 3 + } + } + , initScreenMode = SDL.Windowed + , canvasSize = Nothing + , loadState = load + , preLoop = pre + , eventLoop = handle + , updateLoop = update + , drawLoop = draw + , cleanUp = clean + } withAffection conf -data UserData = UserData - { nodeGraph :: M.Map String G.GeglNode - } +load :: IO StateData +load = do + empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection StateData ())]) + empty2 <- newTVarIO [] -- ([] :: [(UUID, MouseMessage -> Affection StateData ())]) + empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection StateData ())]) + return $ StateData $ Subsystems + (Window empty1) + (Mouse empty2) + (Keyboard empty3) -load :: SDL.Surface -> IO UserData -load _ = do - traceM "loading" - root <- G.gegl_node_new - traceM "new root node" - checkerboard <- G.gegl_node_new_child root $ G.checkerboardOperation $ - props $ do - prop "color1" $ G.RGBA 0.4 0.4 0.4 1 - prop "color2" $ G.RGBA 0.6 0.6 0.6 1 - traceM "checkerboard" - over <- G.gegl_node_new_child root G.defaultOverOperation - traceM "over" - text <- G.gegl_node_new_child root $ G.textOperation $ - props $ do - prop "string" ("Hello world!"::String) - prop "color" $ G.RGBA 0 0 1 0.5 - prop "size" (40::Int) - traceM "text" - G.gegl_node_link checkerboard over - G.gegl_node_connect_to text "output" over "aux" - traceM "connections made" - myMap <- return $ M.fromList - [ ("root" , root) - , ("over" , over) - , ("checkerboard", checkerboard) - , ("text" , text) - ] - traceM "loading complete" - return $ UserData - { nodeGraph = myMap - } +pre :: Affection StateData () +pre = do + sd <- getAffection + _ <- partSubscribe (subKeyboard $ sdSubs sd) exitOnQ + _ <- partSubscribe (subWindow $ sdSubs sd) exitOnWindowClose + return () -draw :: Affection UserData () -draw = do - traceM "drawing" - AffectionData{..} <- get - let UserData{..} = userState - liftIO $ SDL.lockSurface drawSurface - pixels <- liftIO $ SDL.surfacePixels drawSurface - let SDL.Surface rawSurfacePtr _ = drawSurface - rawSurface <- liftIO $ peek rawSurfacePtr - pixelFormat <- liftIO $ peek $ Raw.surfaceFormat rawSurface - format <- liftIO $ (B.babl_format $ B.PixelFormat B.RGBA B.CFu8) - SDL.V2 (CInt rw) (CInt rh) <- SDL.surfaceDimensions drawSurface - let (w, h) = (fromIntegral rw, fromIntegral rh) - liftIO $ G.gegl_node_blit - (nodeGraph M.! "over" :: G.GeglNode) - 1 - (G.GeglRectangle 0 0 w h) - format - pixels - (fromIntegral (Raw.pixelFormatBytesPerPixel pixelFormat) * w) - [G.GeglBlitDefault] - liftIO $ SDL.unlockSurface drawSurface - liftIO $ SDL.updateWindowSurface drawWindow +exitOnQ :: KeyboardMessage -> Affection StateData () +exitOnQ (MsgKeyboardEvent _ _ _ _ sym) = + case SDL.keysymKeycode sym of + SDL.KeycodeQ -> do + liftIO $ logIO Debug "Yo dog I heard..." + quit + _ -> return () -handle :: SDL.EventPayload -> Affection UserData () -handle = const $ return () +exitOnWindowClose :: WindowMessage -> Affection StateData () +exitOnWindowClose wm = + case wm of + MsgWindowClose _ _ -> do + liftIO $ logIO Debug "I heard another one..." + quit + _ -> return () -update :: Affection UserData () -update = do - traceM "updating" - ad <- get - ud@UserData{..} <- getAffection +handle :: [SDL.EventPayload] -> Affection StateData () +handle es = do + (Subsystems a b c) <- sdSubs <$> getAffection + _ <- consumeSDLEvents a es + _ <- consumeSDLEvents b es + _ <- consumeSDLEvents c es + return () - sec <- getDelta - traceM $ (show $ 1 / sec) ++ " FPS" - when (elapsedTime ad > 5) $ - put $ ad - { quitEvent = True - } +update _ = return () -clean :: UserData -> IO () +draw = return () + clean _ = return () diff --git a/examples/example01.hs b/examples/example01.hs deleted file mode 100644 --- a/examples/example01.hs +++ /dev/null @@ -1,109 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - -import Affection -import qualified SDL -import qualified SDL.Raw as Raw -import qualified GEGL as G -import qualified BABL as B -import qualified Data.Map.Strict as M - -import Control.Monad (when) - -import Foreign.Storable (peek) -import Foreign.C.Types - -import Debug.Trace - --- main :: IO () --- main = withAllAffection $ --- withDefaultWindow "test" $ do --- changeColor $ RGBA 255 255 255 255 --- clear --- present --- liftIO $ delaySec 2 - -main :: IO () -main = do - conf <- return $ AffectionConfig - { initComponents = All - , windowTitle = "Affection: example00" - , windowConfig = SDL.defaultWindow - , preLoop = return () - , eventLoop = const $ return () - , updateLoop = update - , drawLoop = draw - , loadState = load - , cleanUp = clean - } - withAffection conf - -data UserData = UserData - { nodeGraph :: M.Map String G.GeglNode - , foreground :: G.GeglBuffer - -- , lastTick :: Double - } - -load :: SDL.Surface -> IO UserData -load _ = do - traceM "loading" - root <- G.gegl_node_new - traceM "new root node" - checkerboard <- G.gegl_node_new_child root $ G.checkerboardOperation $ - props $ do - prop "color1" $ G.RGBA 0.4 0.4 0.4 1 - prop "color2" $ G.RGBA 0.6 0.6 0.6 1 - traceM "checkerboard" - over <- G.gegl_node_new_child root G.defaultOverOperation - traceM "over" - buffer <- G.gegl_buffer_new (Just $ G.GeglRectangle 0 0 800 600) =<< - B.babl_format (B.PixelFormat B.RGBA B.CFfloat) - sink <- G.gegl_node_new_child root $ G.Operation "gegl:copy-buffer" $ - props $ - prop "buffer" buffer - traceM "buffer-source" - nop <- G.gegl_node_new_child root $ G.Operation "gegl:nop" [] - traceM "nop" - crop <- G.gegl_node_new_child root $ G.Operation "gegl:crop" $ - props $ do - prop "width" (800::Double) - prop "height" (600.0::Double) - G.gegl_node_link_many [checkerboard, over, crop, sink] - G.gegl_node_connect_to nop "output" over "aux" - traceM "connections made" - myMap <- return $ M.fromList - [ ("root" , root) - , ("over" , over) - , ("background" , checkerboard) - , ("sink" , sink) - , ("nop" , nop) - ] - let roi = G.GeglRectangle 0 0 20 20 - traceM "loading complete" - return $ UserData - { nodeGraph = myMap - , foreground = buffer - -- , lastTick = 0 - } - -draw :: Affection UserData () -draw = do - traceM "drawing" - UserData{..} <- getAffection - drawRect (nodeGraph M.! "nop") (G.RGB 1 0 0) Fill (G.GeglRectangle 10 10 500 500) foreground - process $ nodeGraph M.! "sink" - -update :: Affection UserData () -update = do - traceM "updating" - ud <- getAffection - -- let last = lastTick ud - -- tick <- getTick - -- putAffection $ ud { lastTick = tick } - dt <- getDelta - traceM $ (show $ 1 / dt) ++ " FPS" - elapsed <- getElapsedTime - when (elapsed > 20) $ - quit - -clean :: UserData -> IO () -clean _ = return () diff --git a/examples/example02.1.hs b/examples/example02.1.hs deleted file mode 100644 --- a/examples/example02.1.hs +++ /dev/null @@ -1,169 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - -import Affection -import qualified SDL -import qualified GEGL as G -import qualified BABL as B -import qualified Data.Map.Strict as M - -import Debug.Trace - -main :: IO () -main = do - conf <- return $ AffectionConfig - { initComponents = All - , windowTitle = "Affection: example00" - , windowConfig = SDL.defaultWindow - , preLoop = return () - , eventLoop = handle - , updateLoop = update - , drawLoop = draw - , loadState = load - , cleanUp = clean - } - withAffection conf - -data UserData = UserData - -- { nodeGraph :: M.Map String G.GeglNode - -- , foreground :: G.GeglBuffer - -- , lastTick :: Double - -- } - { coordinates :: (Double, Double) - , lastTick :: Double - } - -load :: SDL.Surface -> IO UserData -load _ = do - -- traceM "loading" - -- root <- G.gegl_node_new - -- traceM "new root node" - -- checkerboard <- G.gegl_node_new_child root $ G.checkerboardOperation $ - -- props $ do - -- prop "color1" $ G.RGBA 0.4 0.4 0.4 1 - -- prop "color2" $ G.RGBA 0.6 0.6 0.6 1 - -- traceM "checkerboard" - -- over <- G.gegl_node_new_child root G.defaultOverOperation - -- traceM "over" - -- buffer <- G.gegl_buffer_new (Just $ G.GeglRectangle 0 0 800 600) =<< - -- B.babl_format (B.PixelFormat B.RGBA B.CFfloat) - -- sink <- G.gegl_node_new_child root $ G.Operation "gegl:copy-buffer" $ - -- props $ - -- prop "buffer" buffer - -- traceM "buffer-sink" - -- rect <- G.gegl_node_new_child root $ G.Operation "gegl:rectangle" $ - -- props $ do - -- prop "x" (0::Double) - -- prop "y" (0::Double) - -- prop "width" (20::Double) - -- prop "height" (20::Double) - -- prop "color" $ G.RGBA 1 0 0 0.5 - -- traceM "rect" - -- crop <- G.gegl_node_new_child root $ G.Operation "gegl:crop" $ - -- props $ do - -- prop "width" (800::Double) - -- prop "height" (600::Double) - -- G.gegl_node_link_many [checkerboard, over, crop, sink] - -- _ <- G.gegl_node_connect_to rect "output" over "aux" - -- traceM "connections made" - -- myMap <- return $ M.fromList - -- [ ("root" , root) - -- , ("over" , over) - -- , ("background" , checkerboard) - -- , ("sink" , sink) - -- , ("rect" , rect) - -- , ("crop" , crop) - -- ] - -- traceM "loading complete" - -- return $ UserData - -- { nodeGraph = myMap - -- , foreground = buffer - -- , lastTick = 0 - -- } - return $ UserData - { coordinates = (400, 300) - , lastTick = 0 - } - --- drawInit :: Affection UserData () --- drawInit = do --- UserData{..} <- getAffection --- present (GeglRectangle 0 0 800 600) foreground True - -draw :: Affection UserData () -draw = do - UserData{..} <- getAffection - traceM "loading" - root <- liftIO $ G.gegl_node_new - traceM "new root node" - checkerboard <- liftIO $ G.gegl_node_new_child root $ G.checkerboardOperation $ - props $ do - prop "color1" $ G.RGBA 0.4 0.4 0.4 1 - prop "color2" $ G.RGBA 0.6 0.6 0.6 1 - traceM "checkerboard" - over <- liftIO $ G.gegl_node_new_child root G.defaultOverOperation - traceM "over" - buffer <- liftIO $ G.gegl_buffer_new (Just $ G.GeglRectangle 0 0 800 600) =<< - B.babl_format (B.PixelFormat B.RGBA B.CFfloat) - sink <- liftIO $ G.gegl_node_new_child root $ G.Operation "gegl:copy-buffer" $ - props $ - prop "buffer" buffer - traceM "buffer-sink" - rect <- liftIO $ G.gegl_node_new_child root $ G.Operation "gegl:rectangle" $ - props $ do - prop "x" $ fst coordinates - prop "y" $ snd coordinates - prop "width" (20::Double) - prop "height" (20::Double) - prop "color" $ G.RGBA 1 0 0 0.5 - traceM "rect" - crop <- liftIO $ G.gegl_node_new_child root $ G.Operation "gegl:crop" $ - props $ do - prop "width" (800::Double) - prop "height" (600::Double) - liftIO $ G.gegl_node_link_many [checkerboard, over, crop, sink] - _ <- liftIO $ G.gegl_node_connect_to rect "output" over "aux" - traceM "connections made" - myMap <- return $ M.fromList - [ ("root" , root) - , ("over" , over) - , ("background" , checkerboard) - , ("sink" , sink) - , ("rect" , rect) - , ("crop" , crop) - ] - traceM "loading complete" - process (myMap M.! "sink") - present (GeglRectangle 0 0 800 600) buffer True - -update :: Affection UserData () -update = do - traceM "updating" - - tick <- getElapsedTime - ud <- getAffection - putAffection $ ud { lastTick = tick } - - let dt = tick - lastTick ud - return () - traceM $ (show $ 1 / dt) ++ " FPS" - -handle (SDL.MouseMotionEvent dat) = do - let (SDL.P (SDL.V2 x y)) = SDL.mouseMotionEventPos dat - ud <- getAffection - putAffection ud - { coordinates = (fromIntegral (x - 10), fromIntegral (y - 10)) - } - -- liftIO $ G.gegl_node_set (nodeGraph ud M.! "rect") $ G.Operation "" $ - -- props $ do - -- prop "x" (fromIntegral (x - 10) :: Double) - -- prop "y" $ (fromIntegral (y - 10) :: Double) - -handle (SDL.WindowClosedEvent _) = do - traceM "seeya!" - quit - -handle _ = - return () - -clean :: UserData -> IO () -clean _ = return () diff --git a/examples/example02.hs b/examples/example02.hs deleted file mode 100644 --- a/examples/example02.hs +++ /dev/null @@ -1,141 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - -import Affection -import qualified SDL -import qualified GEGL as G -import qualified BABL as B -import qualified Data.Map.Strict as M - -import Debug.Trace - -main :: IO () -main = do - conf <- return AffectionConfig - { initComponents = All - , windowTitle = "Affection: example00" - , windowConfig = SDL.defaultWindow - , preLoop = return () - , eventLoop = handle - , updateLoop = update - , drawLoop = draw - , loadState = load - , cleanUp = clean - } - withAffection conf - -data UserData = UserData - { nodeGraph :: M.Map String G.GeglNode - , actors :: M.Map String Actor - , foreground :: G.GeglBuffer - , lastTick :: Double - } - -load :: SDL.Surface -> IO UserData -load _ = do - traceM "loading" - root <- G.gegl_node_new - traceM "new root node" - checkerboard <- G.gegl_node_new_child root $ G.checkerboardOperation $ - props $ do - prop "color1" $ G.RGBA 0.4 0.4 0.4 1 - prop "color2" $ G.RGBA 0.6 0.6 0.6 1 - traceM "checkerboard" - over <- G.gegl_node_new_child root G.defaultOverOperation - traceM "over" - buffer <- G.gegl_buffer_new (Just $ G.GeglRectangle 0 0 800 600) =<< - B.babl_format (B.PixelFormat B.RGBA B.CFfloat) - sink <- G.gegl_node_new_child root $ G.Operation "gegl:copy-buffer" $ - props $ - prop "buffer" buffer - traceM "buffer-sink" - rectProps <- return $ - props $ do - prop "x" (0::Double) - prop "y" (0::Double) - prop "width" (20::Double) - prop "height" (20::Double) - prop "color" $ G.RGBA 1 0 0 0.5 - rect <- G.gegl_node_new_child root $ G.Operation "gegl:rectangle" rectProps - traceM "rect" - crop <- G.gegl_node_new_child root $ G.Operation "gegl:crop" $ - props $ do - prop "width" (800::Double) - prop "height" (600::Double) - G.gegl_node_link_many [checkerboard, over, crop, sink] - _ <- G.gegl_node_connect_to rect "output" over "aux" - let rectActor = Actor rectProps rect - traceM "connections made" - myMap <- return $ M.fromList - [ ("root" , root) - , ("over" , over) - , ("background" , checkerboard) - , ("sink" , sink) - , ("rect" , rect) - , ("crop" , crop) - ] - traceM "loading complete" - actorMap <- return $ M.fromList - [ ("rect", rectActor) - ] - return UserData - { nodeGraph = myMap - , actors = actorMap - , foreground = buffer - , lastTick = 0 - } - --- drawInit :: Affection UserData () --- drawInit = do --- UserData{..} <- getAffection --- present (GeglRectangle 0 0 800 600) foreground True - -draw :: Affection UserData () -draw = do - UserData{..} <- getAffection - mapM_ (\(Actor ps node) -> liftIO $ G.gegl_node_set node $ G.Operation "" ps) actors - process (nodeGraph M.! "sink") - present (GeglRectangle 0 0 800 600) foreground True - -update :: Affection UserData () -update = do - traceM "updating" - - tick <- getElapsedTime - ud <- getAffection - putAffection $ ud { lastTick = tick } - - let dt = tick - lastTick ud - return () - traceM $ show (1 / dt) ++ " FPS" - -handle :: SDL.EventPayload -> Affection UserData () -handle (SDL.MouseMotionEvent dat) = do - let (SDL.P (SDL.V2 x y)) = SDL.mouseMotionEventPos dat - ud <- getAffection - - nmap <- return $ M.adjust - (Actor (props $ do - prop "y" (fromIntegral (y - 10) :: Double) - prop "x" (fromIntegral (x - 10) :: Double) - ) - . actorNode - ) - "rect" - (actors ud) - putAffection ud - { actors = nmap - } - -- liftIO $ G.gegl_node_set (nodeGraph ud M.! "rect") $ G.Operation "" $ - -- props $ do - -- prop "x" (fromIntegral (x - 10) :: Double) - -- prop "y" $ (fromIntegral (y - 10) :: Double) - -handle (SDL.WindowClosedEvent _) = do - traceM "seeya!" - quit - -handle _ = - return () - -clean :: UserData -> IO () -clean _ = return () diff --git a/examples/example03.hs b/examples/example03.hs deleted file mode 100644 --- a/examples/example03.hs +++ /dev/null @@ -1,200 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE BangPatterns #-} - -import Affection -import qualified SDL -import qualified GEGL as G -import qualified BABL as B - -import qualified Data.Map.Strict as M - -import Control.Monad (when) - -import Foreign.C.Types - -import System.Random (randomRIO) - -import Debug.Trace - -main :: IO () -main = do - conf <- return $ AffectionConfig - { initComponents = All - , windowTitle = "Affection: example00" - , windowConfig = SDL.defaultWindow - , preLoop = drawInit - , eventLoop = handle - , updateLoop = update - , drawLoop = draw - , loadState = load - , cleanUp = clean - } - withAffection conf - -data UserData = UserData - { nodeGraph :: M.Map String G.GeglNode - , foreground :: G.GeglBuffer - , partsys :: ParticleSystem - } - -load :: SDL.Surface -> IO UserData -load _ = do - traceM "loading" - root <- G.gegl_node_new - traceM "new root node" - rect <- G.gegl_node_new_child root $ G.Operation "gegl:rectangle" $ - props $ do - prop "x" (0 :: Double) - prop "y" (0 :: Double) - prop "width" (800 :: Double) - prop "height" (600 :: Double) - prop "color" $ G.RGB 0 0 0 - traceM "rect" - traceM "checkerboard" - over <- G.gegl_node_new_child root G.defaultOverOperation - traceM "over" - buffer <- G.gegl_buffer_new (Just $ G.GeglRectangle 0 0 800 600) =<< - B.babl_format (B.PixelFormat B.RGBA B.CFfloat) - sink <- G.gegl_node_new_child root $ G.Operation "gegl:copy-buffer" - [G.Property "buffer" $ G.PropertyBuffer buffer - ] - traceM "buffer-sink" - nop <- G.gegl_node_new_child root $ G.Operation "gegl:nop" [] - traceM "nop" - crop <- G.gegl_node_new_child root $ G.Operation "gegl:crop" - [ G.Property "width" $ G.PropertyDouble 800 - , G.Property "height" $ G.PropertyDouble 600 - ] - traceM "crop" - G.gegl_node_link_many [rect, over, crop, sink] - G.gegl_node_connect_to nop "output" over "aux" - traceM "connections made" - myMap <- return $ M.fromList - [ ("root" , root) - , ("over" , over) - , ("sink" , sink) - , ("nop" , nop) - , ("crop" , crop) - ] - traceM "loading complete" - return $ UserData - { nodeGraph = myMap - , foreground = buffer - , partsys = ParticleSystem (ParticleStorage Nothing []) nop buffer - } - -drawInit :: Affection UserData () -drawInit = return () --- drawInit = do --- UserData{..} <- getAffection --- present (GeglRectangle 0 0 800 600) foreground True - -draw :: Affection UserData () -draw = do - traceM "drawing" - UserData{..} <- getAffection - drawParticleSystem partsys partDraw - process $ nodeGraph M.! "sink" - present - (G.GeglRectangle 0 0 800 600) - foreground - True - -update :: Affection UserData () -update = do - traceM "updating" - ad <- get - ud <- getAffection - delta <- getDelta - traceM $ (show $ 1 / delta) ++ " FPS" - ud2 <- getAffection - !nps <- updateParticleSystem (partsys ud2) delta partUpd - putAffection $ ud2 { partsys = nps } - -handle (SDL.MouseMotionEvent dat) = - when (SDL.ButtonLeft `elem` SDL.mouseMotionEventState dat) - $ do - ad <- get - ud <- getAffection - let (SDL.P (SDL.V2 x y)) = SDL.mouseMotionEventPos dat - vx <- liftIO $ randomRIO (-20, 20) - vy <- liftIO $ randomRIO (-20, 20) - life <- liftIO $ randomRIO (1, 5) - r <- liftIO $ randomRIO (0,1) - g <- liftIO $ randomRIO (0,1) - b <- liftIO $ randomRIO (0,1) - tempRoot <- liftIO $ G.gegl_node_new - tempOver <- liftIO $ G.gegl_node_new_child tempRoot - G.defaultOverOperation - tempRect <- liftIO $ G.gegl_node_new_child tempRoot $ G.Operation - "gegl:rectangle" - [ G.Property "x" $ G.PropertyDouble $ fromIntegral x - 10 - , G.Property "y" $ G.PropertyDouble $ fromIntegral y - 10 - , G.Property "width" $ G.PropertyDouble 20 - , G.Property "height" $ G.PropertyDouble 20 - , G.Property "color" $ G.PropertyColor $ (G.RGBA r g b 0.5) - ] - liftIO $ G.gegl_node_connect_to tempRect "output" tempOver "aux" - -- traceM $ "position is: " ++ show x ++ " " ++ show y - -- traceM $ "velocity is: " ++ show vx ++ " " ++ show vy - ips <- insertParticle (partsys ud) $ - Particle - { particleTimeToLive = life - , particleCreation = elapsedTime ad - , particlePosition = (fromIntegral x, fromIntegral y) - , particleRotation = Rad 0 - , particleVelocity = (vx, vy) - , particlePitchRate = Rad 0 - , particleRootNode = tempRoot - , particleNodeGraph = M.fromList - [ ("root", tempRoot) - , ("over", tempOver) - , ("rect", tempRect) - ] - , particleStackCont = tempOver - , particleDrawFlange = tempOver - } - putAffection $ ud - { partsys = ips - } - -- when (not $ null $ psParts $ partsys ud) $ - -- liftIO $ G.gegl_node_link - -- tempOver - -- (particleStackCont $ head $ psParts $ partsys ud) - -handle (SDL.WindowClosedEvent _) = do - traceM "seeya!" - quit - -handle _ = - return () - -clean :: UserData -> IO () -clean ud = do - G.gegl_node_drop (nodeGraph ud M.! "root") - -partUpd :: Double -> Particle -> Affection UserData Particle -partUpd sec p = do - let !newX = (fst $ particlePosition p) + sec * (fromIntegral $ fst $ particleVelocity p) - !newY = (snd $ particlePosition p) + sec * (fromIntegral $ snd $ particleVelocity p) - liftIO $ G.gegl_node_set (particleNodeGraph p M.! "rect") $ G.Operation "gegl:rectangle" - [ G.Property "x" $ G.PropertyDouble $ newX - 10 - , G.Property "y" $ G.PropertyDouble $ newY - 10 - ] - let !np = p {particlePosition = (newX, newY)} - return np - -partDraw :: G.GeglBuffer -> G.GeglNode -> Particle -> Affection UserData () -partDraw _ _ _ = return () --- partDraw buf node Particle{..} = do --- present --- (G.GeglRectangle (floor $ fst particlePosition - 10) (floor $ snd particlePosition - 10) 20 20) --- buf --- False --- -- ud <- getAffection --- -- drawRect' --- -- particleDrawFlange --- -- (G.RGBA 1 0 0 0.5) --- -- (Fill) --- -- (G.GeglRectangle ((floor $ fst particlePosition) - 10) ((floor $ snd particlePosition) -10) 20 20) --- -- buf diff --git a/src/Affection.hs b/src/Affection.hs --- a/src/Affection.hs +++ b/src/Affection.hs @@ -2,211 +2,159 @@ {-# LANGUAGE BangPatterns #-} module Affection ( withAffection - , getAffection - , putAffection - -- , withWindow - -- , withDefaultWindow - , delaySec , get , put - , getElapsedTime - , getDelta - , quit , module A ) where +import SDL (($=)) import qualified SDL -import qualified SDL.Internal.Numbered as SDL (toNumber) -import qualified SDL.Raw as Raw -import qualified GEGL as G -import Data.Maybe -import Data.IORef - import System.Clock import Control.Monad.Loops -import qualified Control.Monad.Parallel as MP import Control.Monad.State import Foreign.C.Types (CInt(..)) -import Foreign.Storable (peek) import Debug.Trace import Affection.Types as A -import Affection.Draw as A -import Affection.Particle as A import Affection.StateMachine as A import Affection.MouseInteractable as A -import Affection.Property as A -import Affection.Actor as A +import Affection.Util as A +import Affection.MessageBus as A +import Affection.Subsystems as A -import qualified BABL as B +import Affection.Logging as A +import Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..)) + + -- | Main function which bootstraps everything else. withAffection :: AffectionConfig us -- ^ Configuration of the Game and its engine. -> IO () withAffection AffectionConfig{..} = do + liftIO $ logIO Debug "Affection starting" + liftIO $ logIO Debug "Initializing SDL" -- intialiaze SDL case initComponents of All -> SDL.initializeAll Only is -> SDL.initialize is - G.gegl_init -- give SDL render quality SDL.HintRenderScaleQuality SDL.$= SDL.ScaleLinear -- just checking… do renderQuality <- SDL.get SDL.HintRenderScaleQuality when (renderQuality /= SDL.ScaleLinear) $ - putStrLn "Warning: Linear texture filtering not enabled!" - -- get current time - execTime <- newIORef =<< getTime Monotonic + logIO Warn "Linear texture filtering not enabled!" -- construct window + liftIO $ logIO Debug "Creating Window" window <- SDL.createWindow windowTitle windowConfig SDL.showWindow window - -- create renderer - renderer <- SDL.createRenderer - window - (-1) - SDL.defaultRenderer - -- make draw surface - surface <- SDL.createRGBSurface - (SDL.windowInitialSize windowConfig) - SDL.ABGR8888 - let (SDL.Surface ptr _) = surface - pixelFormat <- liftIO $ peek . Raw.surfaceFormat =<< peek ptr - SDL.V2 (CInt rw) (CInt rh) <- liftIO $ SDL.surfaceDimensions surface - let (w, h) = (fromIntegral rw, fromIntegral rh) - stride = fromIntegral (Raw.pixelFormatBytesPerPixel pixelFormat) * w - pixels <- SDL.surfacePixels surface - let bablFormat = B.PixelFormat B.RGBA B.CFu8 - cpp = B.babl_components_per_pixel bablFormat - format <- B.babl_format bablFormat + -- renderer <- SDL.createRenderer + -- window (-1) + -- SDL.defaultRenderer + -- { SDL.rendererTargetTexture = True + -- } + -- surface <- SDL.createRGBSurface + -- (case canvasSize of + -- Just (cw, ch) -> SDL.V2 + -- (CInt $ fromIntegral cw) + -- (CInt $ fromIntegral ch) + -- Nothing -> + -- SDL.windowInitialSize windowConfig + -- ) + -- SDL.RGBA8888 + -- texture <- SDL.createTexture + -- renderer + -- SDL.RGBA8888 + -- SDL.TextureAccessTarget + -- (case canvasSize of + -- Just (cw, ch) -> SDL.V2 + -- (CInt $ fromIntegral cw) + -- (CInt $ fromIntegral ch) + -- Nothing -> + -- SDL.windowInitialSize windowConfig + -- ) + -- SDL.rendererRenderTarget renderer $= Just texture + context <- SDL.glCreateContext window + let SDL.V2 (CInt rw) (CInt rh) = SDL.windowInitialSize windowConfig + (w, h) = case canvasSize of + Just (cw, ch) -> (cw, ch) + Nothing -> (fromIntegral rw, fromIntegral rh) + SDL.setWindowMode window initScreenMode + SDL.swapInterval $= SDL.SynchronizedUpdates + liftIO $ logIO Debug "Getting Time" + -- get current time + execTime <- getTime Monotonic + liftIO $ logIO Debug "Loading initial data container" initContainer <- (\x -> AffectionData { quitEvent = False , userState = x , drawWindow = window - , windowRenderer = renderer - , drawSurface = surface - , drawFormat = format - , drawPixels = pixels - , drawDimensions = (w, h) - , drawStride = stride - , drawCPP = cpp - , drawStack = [] + , glContext = context + , drawDimensions = case canvasSize of + Just (cw, ch) -> (cw, ch) + Nothing -> (w, h) + , screenMode = initScreenMode , elapsedTime = 0 - , dt = 0 - }) <$> loadState surface + , deltaTime = 0 + , sysTime = execTime + , pausedTime = False + }) <$> loadState (_, nState) <- runStateT ( A.runState $ do + liftIO $ logIO Debug "Starting Loop" preLoop whileM_ (do current <- get return $ not $ A.quitEvent current ) (do - -- Measure time difference form last run - now <- liftIO $ getTime Monotonic - lastTime <- liftIO $ readIORef execTime -- get state ad <- get - -- clean draw requests from last run - mapM_ (invalidateDrawRequest (drawPixels ad) (drawStride ad) (drawCPP ad)) (drawStack ad) - -- clean the renderer form last time - -- SDL.clear renderer + -- Measure time difference form last run + now <- liftIO $ getTime Monotonic + let lastTime = sysTime ad -- compute dt and update elapsedTime - let !dt = fromIntegral (toNanoSecs $ diffTimeSpec lastTime now) / (10 ^ 9) + let !dt = fromIntegral + (toNanoSecs $ diffTimeSpec lastTime now) / (10 ^ (9 :: Int)) !ne = elapsedTime ad + dt put $ ad - { drawStack = [] - , elapsedTime = ne - , dt = dt + { elapsedTime = ne + , deltaTime = dt } -- poll events evs <- preHandleEvents =<< liftIO SDL.pollEvents - MP.mapM_ eventLoop evs + -- mapM_ eventLoop evs + eventLoop evs -- execute user defined update loop - updateLoop + unless (pausedTime ad) (updateLoop dt) -- execute user defined draw loop + liftIO $ GL.clear [ColorBuffer, DepthBuffer, StencilBuffer] drawLoop + liftIO flush -- handle all new draw requests ad2 <- get - clear <- catMaybes <$> - mapM (handleDrawRequest (drawPixels ad) (drawStride ad) (drawCPP ad)) (drawStack ad2) - -- save all draw requests to clear in next run - put $ ad2 - { drawStack = clear } - -- get texture from surface - texture <- SDL.createTextureFromSurface (windowRenderer ad2) (drawSurface ad2) -- actual drawing - SDL.copy (windowRenderer ad2) texture Nothing Nothing - SDL.present (windowRenderer ad2) - -- clean the texture - SDL.destroyTexture texture + SDL.glSwapWindow window + -- SDL.copy renderer texture Nothing Nothing + -- SDL.present renderer -- save new time - liftIO $ writeIORef execTime now + ad3 <- get + when (sysTime ad == sysTime ad3) ( + put ad3 + { sysTime = now + } + ) ) ) initContainer - G.gegl_exit + liftIO $ logIO Debug "Loop ended. Cleaning" cleanUp $ userState nState + liftIO $ logIO Debug "Destroying Window" SDL.destroyWindow window SDL.quit - -getSurfaces :: SDL.Window -> IO (SDL.Surface, SDL.Surface) -getSurfaces window = do - oldSurf@(SDL.Surface ptr _) <- SDL.getWindowSurface window - rawSurfacePtr <- Raw.convertSurfaceFormat ptr (SDL.toNumber SDL.ABGR8888) 0 - let surface = SDL.Surface rawSurfacePtr Nothing - return (oldSurf, surface) - --- Prehandle SDL events in case any window events occur -preHandleEvents :: [SDL.Event] -> Affection us [SDL.EventPayload] -preHandleEvents evs = - -- mapM handle evs - -- where - -- handle e = - -- case SDL.eventPayload e of - -- SDL.WindowMovedEvent _ -> do - -- liftIO $ traceIO "I was moved" - -- return e - -- _ -> - -- return e - return $ map SDL.eventPayload evs - --- | Return the userstate to the user -getAffection :: Affection us us -getAffection = do - ad <- get - return $ userState ad - --- | Put altered user state back -putAffection - :: us -- User state - -> Affection us () -putAffection us = do - ad <- get - put $ ad - { userState = us } - --- | block a thread for a specified amount of time -delaySec - :: Int -- ^ Number of seconds - -> IO () -delaySec dur = SDL.delay (fromIntegral $ dur * 1000) - --- | Get time since start but always the same in the current tick. -getElapsedTime :: Affection us Double -getElapsedTime = - elapsedTime <$> get - -getDelta :: Affection us Double -getDelta = - dt <$> get - -quit :: Affection us () -quit = do - ad <- get - put $ ad { quitEvent = True } + liftIO $ logIO Debug "This is the end" diff --git a/src/Affection/Actor.hs b/src/Affection/Actor.hs deleted file mode 100644 --- a/src/Affection/Actor.hs +++ /dev/null @@ -1,12 +0,0 @@ --- | This module implements the Actor, a Datastructure binding a 'G.GeglNode' --- to a game asset -module Affection.Actor - ( Actor(..) - ) where - -import qualified GEGL as G - -data Actor = Actor - { actorProperties :: [G.Property] - , actorNode :: G.GeglNode - } diff --git a/src/Affection/Draw.hs b/src/Affection/Draw.hs deleted file mode 100644 --- a/src/Affection/Draw.hs +++ /dev/null @@ -1,201 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - --- | Module for drawing primitives -module Affection.Draw - ( drawRect - , clear - , handleDrawRequest - , invalidateDrawRequest - , present - , process - , clearArea - ) where - -import Affection.Types - -import Data.Maybe (maybe) - -import Foreign -import Foreign.C.Types - -import Control.Monad.State (get, put) -import Control.Monad (when, unless) - -import System.Glib.GObject - -import qualified SDL - -import qualified BABL as B - -import qualified GEGL as G - -import Debug.Trace - -drawRect - :: G.GeglNode -- ^ Target Node - -> G.Color -- ^ Color to draw in - -> DrawType -- ^ Draw type - -> G.GeglRectangle -- ^ Dimensions of Rectangle - -> G.GeglBuffer -- ^ Final Buffer - -> Affection us () -drawRect node color Fill rect@GeglRectangle{..} buf = do - ad <- get - tempRoot <- liftIO G.gegl_node_new - opNode <- liftIO $ G.gegl_node_new_child tempRoot $ G.Operation "gegl:rectangle" - [ G.Property "x" $ G.PropertyDouble $ fromIntegral rectangleX - , G.Property "y" $ G.PropertyDouble $ fromIntegral rectangleY - , G.Property "width" $ G.PropertyDouble $ fromIntegral rectangleWidth - , G.Property "height" $ G.PropertyDouble $ fromIntegral rectangleHeight - , G.Property "color" $ G.PropertyColor color - ] - diw <- liftIO $ G.gegl_node_connect_to opNode "output" node "input" - unless diw $ error "Affection.Draw.drawRect: connect failed" - put $ ad - { drawStack = DrawRequest rect buf (Kill (Just tempRoot)) : drawStack ad - } - --- | Force update of a specific region on screen -present - :: G.GeglRectangle -- ^ Area to be updated - -> G.GeglBuffer -- ^ Target buffer - -> Bool -- ^ Shall the 'DrawRequest' persist? - -> Affection us () -present rect buf kill = do - ad <- get - let k = if not kill then Kill Nothing else Persist - put ad - { drawStack = DrawRequest rect buf k : drawStack ad - } - -process - :: G.GeglNode - -> Affection us () -process = liftIO . G.gegl_node_process - -putToSurface - :: Ptr a - -> G.GeglRectangle - -> Int - -> Int - -> DrawRequest - -> Affection us () -putToSurface pixels realRect stride cpp DrawRequest{..} = do - ad <- get - liftIO $ SDL.lockSurface $ drawSurface ad - liftIO $ G.gegl_buffer_get - requestBuffer - (Just realRect) - 1 - (Just $ drawFormat ad) - (pixels `plusPtr` - (rectangleX realRect * cpp + rectangleY realRect * stride)) - stride - G.GeglAbyssNone - liftIO $ SDL.unlockSurface $ drawSurface ad - --- | function for handling 'DrawRequest's and updating the output -handleDrawRequest - :: Ptr a -- ^ Pixel buffer to blit to - -- -> B.BablFormatPtr -- ^ format to blit in - -> Int -- ^ Stride - -> Int -- ^ Components per Pixel - -> DrawRequest -- ^ 'DrawRequest' to handle - -> Affection us (Maybe DrawRequest) -handleDrawRequest pixels stride cpp dr@DrawRequest{..} = do - ad <- get - let surf = drawSurface ad - mrealRect <- liftIO $ G.gegl_rectangle_intersect - requestArea - (uncurry (G.GeglRectangle 0 0) (drawDimensions ad)) - maybe (return()) (\realRect -> - putToSurface pixels realRect stride cpp dr - ) mrealRect - case requestPersist of - Persist -> - return Nothing - Kill _ -> - return $ Just dr - --- | clear a previously drawn area -invalidateDrawRequest - :: Ptr a -- ^ Pixel buffer to blit to - -- -> B.BablFormatPtr -- ^ format to blit in - -> Int -- ^ Stride - -> Int -- ^ Components per Pixel - -> DrawRequest -- ^ Drawrequest to invalidate - -> Affection us () -invalidateDrawRequest pixels stride cpp dr@DrawRequest{..} = do - ad <- get - mrealRect <- liftIO $ G.gegl_rectangle_intersect - requestArea - (uncurry (G.GeglRectangle 0 0) (drawDimensions ad)) - maybe (return()) (\realRect -> do - liftIO $ clearArea requestBuffer realRect - putToSurface pixels realRect stride cpp dr - ) mrealRect - case requestPersist of - Kill (Just victim) -> - liftIO $ G.gegl_node_drop victim - _ -> - return () - -- liftIO $ SDL.updateWindowSurface $ drawWindow ad - --- | compute color for a single pixel -colorize - :: (G.ComponentValue, G.ComponentValue, G.ComponentValue, G.ComponentValue) -- ^ Pixel information in buffer - -> G.Color -- ^ Color to draw over - -> (G.ComponentValue, G.ComponentValue, G.ComponentValue, G.ComponentValue) -- ^ Resulting colour -colorize (rr, rg, rb, ra) col = - let (G.CVdouble (CDouble br)) = rr - (G.CVdouble (CDouble bg)) = rg - (G.CVdouble (CDouble bb)) = rb - (G.CVdouble (CDouble ba)) = ra - (cr, cg, cb) = case col of - G.RGBA r g b _ -> (r, g, b) - G.RGB r g b -> (r, g, b) - ca = case col of - G.RGBA _ _ _ a -> a - G.RGB{} -> 1 - alpha = ca - dst_a = ba - da = alpha + dst_a * (1 - alpha) - a_term = dst_a * (1 - alpha) - red = cr * alpha + br * a_term - gre = cg * alpha + bg * a_term - blu = cb * alpha + bb * a_term - in - ( G.CVdouble $ CDouble $ red / da - , G.CVdouble $ CDouble $ gre / da - , G.CVdouble $ CDouble $ blu / da - , G.CVdouble $ CDouble ca - ) - -unsafeColorize col = - let - (r, g, b) = case col of - G.RGBA cr cg cb _ -> (cr, cg, cb) - G.RGB cr cg cb -> (cr, cg, cb) - a = case col of - G.RGBA _ _ _ ca -> ca - G.RGB{} -> 1 - in - ( G.CVdouble $ CDouble r - , G.CVdouble $ CDouble g - , G.CVdouble $ CDouble b - , G.CVdouble $ CDouble a - ) - --- | Clear a specified area of a buffer from all data -clearArea - :: G.GeglBuffer -- ^ Target buffer - -> G.GeglRectangle -- ^ Area to clear - -> IO () -clearArea = G.gegl_buffer_clear - --- | Clear the whole drawing area -clear :: G.GeglBuffer -> Affection us () -clear buffer = do - ad <- get - SDL.V2 (CInt rw) (CInt rh) <- SDL.surfaceDimensions $ drawSurface ad - let (w, h) = (fromIntegral rw, fromIntegral rh) - liftIO $ clearArea buffer (GeglRectangle 0 0 w h) diff --git a/src/Affection/Logging.hs b/src/Affection/Logging.hs new file mode 100644 --- /dev/null +++ b/src/Affection/Logging.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE CPP #-} +module Affection.Logging where + +import Debug.Trace + +data LogLevel + = Verbose + | Debug + | Warn + | Error + +log :: LogLevel -> String -> a -> a +#if defined(VERBOSE) +log Verbose s = trace ("VERBOSE: " ++ s) +#endif +#if defined(DEBUG) || defined(VERBOSE) +log Debug s = trace ("DEBUG: " ++ s) +#endif +#if defined(WARN) || defined(DEBUG) || defined(VERBOSE) +log Warn s = trace ("WARN: " ++ s) +#endif +#if defined(ERROR) || defined(WARN) || defined(DEBUG) || defined(VERBOSE) +log Error s = trace ("ERROR: " ++ s) +#endif +log _ _ = id + +logIO :: LogLevel -> String -> IO () +#if defined(VERBOSE) +logIO Verbose s = traceIO ("VERBOSE: " ++ s) +#endif +#if defined(DEBUG) || defined(VERBOSE) +logIO Debug s = traceIO ("DEBUG: " ++ s) +#endif +#if defined(WARN) || defined(DEBUG) || defined(VERBOSE) +logIO Warn s = traceIO ("WARN: " ++ s) +#endif +#if defined(ERROR) || defined(WARN) || defined(DEBUG) || defined(VERBOSE) +logIO Error s = traceIO ("ERROR: " ++ s) +#endif +logIO _ _ = return () diff --git a/src/Affection/MessageBus.hs b/src/Affection/MessageBus.hs new file mode 100644 --- /dev/null +++ b/src/Affection/MessageBus.hs @@ -0,0 +1,10 @@ +module Affection.MessageBus + ( module M + , module Msg + ) where + +import Affection.MessageBus.Class as M +import Affection.MessageBus.Message as M +import Affection.MessageBus.Util as M + +import Affection.MessageBus.Message as Msg diff --git a/src/Affection/MessageBus/Class.hs b/src/Affection/MessageBus/Class.hs new file mode 100644 --- /dev/null +++ b/src/Affection/MessageBus/Class.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ExistentialQuantification #-} +module Affection.MessageBus.Class + ( Participant(..) + , genUUID + , UUID + , MsgId(..) + ) where + +import Affection.MessageBus.Message +import Affection.Types + +import Control.Monad.IO.Class (liftIO) + +import Data.UUID +import Data.UUID.V4 + +import Affection.Logging + +class (Message msg, Show msg) => Participant prt msg us where + + -- | Function to get the list of subscribers from the participant + partSubscribers + :: prt + -- ^ the 'Participant''s subscriber storage + -> Affection us [msg -> Affection us ()] + -- ^ List of Subscriber functions + + -- | Subscribe to the 'Participant''s events + partSubscribe + :: prt + -- ^ The 'Participant''s subscriber storage + -> (msg -> Affection us ()) + -- ^ What to do in case of a 'Message' + -- (Subscriber function) + -> Affection us (MsgId msg) + -- ^ 'UUID' of the registered subscriber Function + + -- | Unsubscribe a Subscriber function from Participant + partUnSubscribe + :: prt + -- ^ The 'Participant''s subscriber storage to unsubscribe from + -> (MsgId msg) + -- ^ The subscriber function's 'UUID' + -> Affection us () + + -- | Get the 'Participant' to emit a 'Message' on all of its subscribers + partEmit + :: prt + -- ^ The 'Participant''s subscriber storage + -> msg + -- ^ The 'Message' to emit + -> Affection us () + partEmit p m = do + liftIO $ logIO Verbose $ "Emitting message: " ++ show m + l <- partSubscribers p + mapM_ ($ m) l + +-- | Helper function to generate new 'UUID's +genUUID :: Affection us UUID +genUUID = liftIO nextRandom + +data MsgId msg = (Message msg, Show msg) => MsgId UUID msg diff --git a/src/Affection/MessageBus/Message.hs b/src/Affection/MessageBus/Message.hs new file mode 100644 --- /dev/null +++ b/src/Affection/MessageBus/Message.hs @@ -0,0 +1,8 @@ +module Affection.MessageBus.Message + ( module M + ) where + +import Affection.MessageBus.Message.Class as M +import Affection.MessageBus.Message.WindowMessage as M +import Affection.MessageBus.Message.KeyboardMessage as M +import Affection.MessageBus.Message.MouseMessage as M diff --git a/src/Affection/MessageBus/Message/Class.hs b/src/Affection/MessageBus/Message/Class.hs new file mode 100644 --- /dev/null +++ b/src/Affection/MessageBus/Message/Class.hs @@ -0,0 +1,6 @@ +module Affection.MessageBus.Message.Class where + +import Data.Word (Word32(..)) + +class Message msg where + msgTime :: msg -> Double diff --git a/src/Affection/MessageBus/Message/KeyboardMessage.hs b/src/Affection/MessageBus/Message/KeyboardMessage.hs new file mode 100644 --- /dev/null +++ b/src/Affection/MessageBus/Message/KeyboardMessage.hs @@ -0,0 +1,19 @@ +module Affection.MessageBus.Message.KeyboardMessage where + +import Affection.MessageBus.Message.Class + +import qualified SDL + +data KeyboardMessage + = MsgKeyboardEvent + { msgKbdWhen :: Double + , msgKbdWindow :: Maybe SDL.Window + , msgKbdKeyMotion :: SDL.InputMotion + , msgKbdKeyRepeat :: Bool + , msgKbdKeysym :: SDL.Keysym + } + | MsgKeyboardEmptyEvent + deriving (Show) + +instance Message KeyboardMessage where + msgTime (MsgKeyboardEvent t _ _ _ _) = t diff --git a/src/Affection/MessageBus/Message/MouseMessage.hs b/src/Affection/MessageBus/Message/MouseMessage.hs new file mode 100644 --- /dev/null +++ b/src/Affection/MessageBus/Message/MouseMessage.hs @@ -0,0 +1,42 @@ +module Affection.MessageBus.Message.MouseMessage where + +import Affection.MessageBus.Message.Class + +import Data.Word (Word8(..)) +import Data.Int (Int32(..)) + +import qualified SDL + +import Linear (V2(..)) + +data MouseMessage + = MsgMouseMotion + { msgMMWhen :: Double + , msgMMWindow :: Maybe SDL.Window + , msgMMWhich :: SDL.MouseDevice + , msgMMState :: [SDL.MouseButton] + , msgMMPos :: V2 Int32 + , msgMMRelMotion :: V2 Int32 + } + | MsgMouseButton + { msgMBWhen :: Double + , msgMBWindow :: Maybe SDL.Window + , msgMBWhich :: SDL.MouseDevice + , msgMBButton :: SDL.MouseButton + , msgMBClicks :: Word8 + , msgMBPos :: V2 Int32 + } + | MsgMouseWheel + { msgMWWhen :: Double + , msgMWWhindow :: Maybe SDL.Window + , msgMWWhich :: SDL.MouseDevice + , msgMWPos :: V2 Int32 + , msgMWDIrection :: SDL.MouseScrollDirection + } + | MsgMouseEmptyEvent + deriving (Show) + +instance Message MouseMessage where + msgTime (MsgMouseMotion t _ _ _ _ _) = t + msgTime (MsgMouseButton t _ _ _ _ _) = t + msgTime (MsgMouseWheel t _ _ _ _) = t diff --git a/src/Affection/MessageBus/Message/WindowMessage.hs b/src/Affection/MessageBus/Message/WindowMessage.hs new file mode 100644 --- /dev/null +++ b/src/Affection/MessageBus/Message/WindowMessage.hs @@ -0,0 +1,89 @@ +module Affection.MessageBus.Message.WindowMessage where + +import Affection.MessageBus.Message.Class + +import Data.Int (Int32(..)) + +import qualified SDL + +import Linear (V2(..)) + +data WindowMessage + -- = MsgEngineReady Double + = MsgWindowShow + { msgWSWhen :: Double + , msgWSWindow :: SDL.Window + } + | MsgWindowHide + { msgWHWhen :: Double + , msgWHWindow :: SDL.Window + } + | MsgWindowExpose + { msgWEWhen :: Double + , msgWEWindow :: SDL.Window + } + | MsgWindowMove + { msgWMWhen :: Double + , msgWMWindow :: SDL.Window + , msgWMNewPos :: V2 Int32 + } + | MsgWindowResize + { msgWRWhen :: Double + , msgWRWindow :: SDL.Window + , msgWRNewSize :: V2 Int32 + } + | MsgWindowSizeChange + { msgWSCWhen :: Double + , msgWSCWindow :: SDL.Window + } + | MsgWindowMinimize + { msgWMinWhen :: Double + , msgWMinWindow :: SDL.Window + } + | MsgWindowMaximize + { msgWMaxWhen :: Double + , msgWMaxWindow :: SDL.Window + } + | MsgWindowRestore + { msgWRestWhen :: Double + , msgWRestWindow :: SDL.Window + } + | MsgWindowGainMouseFocus + { msgWGMFWhen :: Double + , msgWGMFWindow :: SDL.Window + } + | MsgWindowLoseMouseFocus + { msgWLMFWhen :: Double + , msgWLMFWindow :: SDL.Window + } + | MsgWindowGainKeyboardFocus + { msgWGKFWhen :: Double + , msgWGKFWindow :: SDL.Window + } + | MsgWindowLoseKeyboardFocus + { msgWLKFWhen :: Double + , msgWLKFWindow :: SDL.Window + } + | MsgWindowClose + { msgWCWhen :: Double + , msgWCWindow :: SDL.Window + } + | MsgWindowEmptyEvent + deriving (Show) + +instance Message WindowMessage where + -- msgTime (MsgEngineReady t) = t + msgTime (MsgWindowShow t _) = t + msgTime (MsgWindowHide t _) = t + msgTime (MsgWindowExpose t _) = t + msgTime (MsgWindowMove t _ _) = t + msgTime (MsgWindowResize t _ _) = t + msgTime (MsgWindowSizeChange t _) = t + msgTime (MsgWindowMinimize t _) = t + msgTime (MsgWindowMaximize t _) = t + msgTime (MsgWindowRestore t _) = t + msgTime (MsgWindowGainMouseFocus t _) = t + msgTime (MsgWindowLoseMouseFocus t _) = t + msgTime (MsgWindowGainKeyboardFocus t _) = t + msgTime (MsgWindowLoseKeyboardFocus t _) = t + msgTime (MsgWindowClose t _) = t diff --git a/src/Affection/MessageBus/Util.hs b/src/Affection/MessageBus/Util.hs new file mode 100644 --- /dev/null +++ b/src/Affection/MessageBus/Util.hs @@ -0,0 +1,3 @@ +module Affection.MessageBus.Util where + +-- zuru zuru diff --git a/src/Affection/MouseInteractable.hs b/src/Affection/MouseInteractable.hs --- a/src/Affection/MouseInteractable.hs +++ b/src/Affection/MouseInteractable.hs @@ -23,11 +23,11 @@ -- This function does not consume provided events, but passes them on. handleMouseClicks :: (Foldable t, MouseClickable clickable us) - => SDL.Event -- ^ Piped event in - -> t clickable -- ^ 'MouseClickable' elemt to be checked - -> Affection us SDL.Event -- ^ Unaltered event + => SDL.EventPayload -- ^ Piped event in + -> t clickable -- ^ 'MouseClickable' elemt to be checked + -> Affection us SDL.EventPayload -- ^ Unaltered event handleMouseClicks e clickables = - case SDL.eventPayload e of + case e of SDL.MouseButtonEvent dat -> do mapM_ (\clickable -> do let SDL.P (SDL.V2 x y) = SDL.mouseButtonEventPos dat diff --git a/src/Affection/Particle.hs b/src/Affection/Particle.hs deleted file mode 100644 --- a/src/Affection/Particle.hs +++ /dev/null @@ -1,154 +0,0 @@ -{-# LANGUAGE BangPatterns #-} - --- | This module introduces a simple particle system to Affection -module Affection.Particle - ( updateParticle - , drawParticles - , updateParticleSystem - , drawParticleSystem - , insertParticle - ) where - -import Affection.Types - -import Control.Monad -import Control.Monad.State (get) -import qualified Control.Monad.Parallel as MP - -import Data.Maybe - -import qualified GEGL as G - -import Debug.Trace - --- This function updates particles through a specified function. Particle ageing --- and death is being handled by 'updateParticles' itself and does not need to --- bother you. -updateParticle - :: Double - -- ^ Elapsed time in seconds - -> (Double -> Particle -> Affection us Particle) - -- ^ Update function for each 'Particle' - -> [Particle] - -- ^ List of 'Particle's to be processed - -> Affection us [Particle] - -- ^ processed 'Particle's -updateParticle time func l = - updateParticle' time func l - where - updateParticle' _ _ [] = return [] - updateParticle' dt fun [p] = do - now <- elapsedTime <$> get - if particleCreation p + particleTimeToLive p < now - then do - dropParticle p - return [] - else - (: []) <$> func time p - updateParticle' dt fun (p:ps) = do - now <- elapsedTime <$> get - if particleCreation p + particleTimeToLive p < now - then do - dropParticle p - updateParticle' dt fun ps - else do - np <- fun dt p - (np :) <$> updateParticle' dt fun ps - dropParticle p = do - mproducer <- liftIO $ G.gegl_node_get_producer - (particleStackCont p) - "input" - maybe (return ()) (\(producer, padname) -> do - consumers <- liftIO $ G.gegl_node_get_consumers - (particleStackCont p) - "output" - liftIO $ mapM_ (uncurry $ G.gegl_node_connect_to - producer - padname - ) consumers - ) mproducer - liftIO $ G.gegl_node_drop $ particleRootNode p - --- | Get the next living particle from a list -nextLiving - :: [Maybe Particle] - -> Maybe Particle -nextLiving [] = Nothing -nextLiving acc = case catMaybes acc of - [] -> Nothing - ps -> Just $ head ps - -drawParticles - :: (Particle -> Affection us ()) - -> [Particle] - -> Affection us () -drawParticles = mapM_ - -updateParticleSystem - :: ParticleSystem - -> Double - -> (Double -> Particle -> Affection us Particle) - -> Affection us ParticleSystem -updateParticleSystem sys sec upd = do - !x <- updateParticle sec upd (partStorList $ partSysParts sys) - if not $ null x - then do - return sys - { partSysParts = (partSysParts sys) - { partStorList = x - } - } - else do - return sys - { partSysParts = ParticleStorage - { partStorList = [] - , partStorLatest = Nothing - } - } - -drawParticleSystem - :: ParticleSystem - -> (G.GeglBuffer -> G.GeglNode -> Particle -> Affection us ()) - -> Affection us () -drawParticleSystem sys draw = - if not (null parts) - then do - liftIO $ G.gegl_node_link (particleStackCont $ head parts) (partSysNode sys) - MP.mapM_ (draw (partSysBuffer sys) (partSysNode sys)) parts - else do - _ <- liftIO $ G.gegl_node_disconnect (partSysNode sys) "input" - return () - where - parts = partStorList (partSysParts sys) - --- | Function for inserting a new 'Particle' into its 'PartileSystem' -insertParticle - :: ParticleSystem -- ^ 'ParticleSystem' to insert into - -> Particle -- ^ 'Particle' to insert - -> Affection us ParticleSystem -- ^ resulting new 'ParticleSystem' -insertParticle ps p = do - now <- elapsedTime <$> get - let newList = chronoInsert now (partStorList $ partSysParts ps) p - liftIO $ G.gegl_node_link_many (reverse $ map particleStackCont newList) - return ps - { partSysParts = (partSysParts ps) - { partStorLatest = Just p - , partStorList = newList - } - } - --- | Insert a 'Particle' into its chronologically ordered list -chronoInsert - :: Double -- ^ Time in seconds from beginning of program execution - -> [Particle] -- ^ List to insert to - -> Particle -- ^ 'Particle' to insert - -> [Particle] -- ^ Resulting list -chronoInsert now [] np = [np] -chronoInsert now [p] np = - if now + particleTimeToLive p < (particleCreation np + particleTimeToLive np) - then p : [np] - else np : [p] -chronoInsert now l@(p:ps) np = - if now + particleTimeToLive p < (particleCreation np + particleTimeToLive np) - then p : chronoInsert now ps np - else np : l diff --git a/src/Affection/Property.hs b/src/Affection/Property.hs deleted file mode 100644 --- a/src/Affection/Property.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -module Affection.Property - ( Props - , prop - , props - ) where - -import qualified GEGL as G -import qualified BABL as B - -import Control.Monad.State.Lazy -import Foreign.Ptr (Ptr) - -type Props a = State [G.Property] a - -props :: Props a -> [G.Property] -props = flip execState [] - -prop :: IsPropertyValue v => String -> v -> Props () -prop k v = do - ps <- get - put $ G.Property k (toPropertyValue v) : ps - -class IsPropertyValue v where - toPropertyValue :: v -> G.PropertyValue - -instance IsPropertyValue Int where - toPropertyValue = G.PropertyInt - -instance IsPropertyValue String where - toPropertyValue = G.PropertyString - -instance IsPropertyValue Double where - toPropertyValue = G.PropertyDouble - -instance IsPropertyValue G.Color where - toPropertyValue = G.PropertyColor - -instance IsPropertyValue B.PixelFormat where - toPropertyValue = G.PropertyFormat -instance IsPropertyValue G.GeglBuffer where - toPropertyValue = G.PropertyBuffer - -instance IsPropertyValue (Ptr ()) where - toPropertyValue = G.PropertyPointer diff --git a/src/Affection/StateMachine.hs b/src/Affection/StateMachine.hs --- a/src/Affection/StateMachine.hs +++ b/src/Affection/StateMachine.hs @@ -9,6 +9,6 @@ class StateMachine a us where smLoad :: a -> Affection us () smUpdate :: a -> Double -> Affection us () - smEvent :: a -> Double -> SDL.Event -> Affection us () + smEvent :: a -> [SDL.EventPayload] -> Affection us () smDraw :: a -> Affection us () smClean :: a -> Affection us () diff --git a/src/Affection/Subsystems.hs b/src/Affection/Subsystems.hs new file mode 100644 --- /dev/null +++ b/src/Affection/Subsystems.hs @@ -0,0 +1,8 @@ +module Affection.Subsystems + ( module S + ) where + +import Affection.Subsystems.Class as S +import Affection.Subsystems.AffectionKeyboard as S +import Affection.Subsystems.AffectionWindow as S +import Affection.Subsystems.AffectionMouse as S diff --git a/src/Affection/Subsystems/AffectionKeyboard.hs b/src/Affection/Subsystems/AffectionKeyboard.hs new file mode 100644 --- /dev/null +++ b/src/Affection/Subsystems/AffectionKeyboard.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +module Affection.Subsystems.AffectionKeyboard where + +import Affection.Types +import Affection.Util +import Affection.MessageBus +import Affection.Subsystems.Class + +import Control.Concurrent.STM as STM +import Control.Monad.IO.Class (liftIO) + +import qualified SDL + +consumeSDLKeyboardEvents + :: (Participant ak KeyboardMessage us) + => ak + -> [SDL.EventPayload] + -> Affection us [SDL.EventPayload] +consumeSDLKeyboardEvents ak = doConsume + where + doConsume [] = return [] + doConsume (e:es) = do + ts <- getElapsedTime + case e of + SDL.KeyboardEvent dat -> do + partEmit ak (MsgKeyboardEvent + ts + (SDL.keyboardEventWindow dat) + (SDL.keyboardEventKeyMotion dat) + (SDL.keyboardEventRepeat dat) + (SDL.keyboardEventKeysym dat) + ) + doConsume es + _ -> fmap (e :) (doConsume es) diff --git a/src/Affection/Subsystems/AffectionMouse.hs b/src/Affection/Subsystems/AffectionMouse.hs new file mode 100644 --- /dev/null +++ b/src/Affection/Subsystems/AffectionMouse.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +module Affection.Subsystems.AffectionMouse where + +import Affection.MessageBus +import Affection.Subsystems.Class +import Affection.Types +import Affection.Util + +import Control.Monad.IO.Class (liftIO) +import Control.Concurrent.STM + +import Linear.Affine (unP) + +import qualified SDL + +consumeSDLMouseEvents + :: (Participant am MouseMessage us) + => am + -> [SDL.EventPayload] + -> Affection us [SDL.EventPayload] +consumeSDLMouseEvents am = doConsume + where + doConsume [] = return [] + doConsume (e:es) = do + ts <- getElapsedTime + case e of + SDL.MouseMotionEvent dat -> do + partEmit am (MsgMouseMotion + ts + (SDL.mouseMotionEventWindow dat) + (SDL.mouseMotionEventWhich dat) + (SDL.mouseMotionEventState dat) + (unP $ SDL.mouseMotionEventPos dat) + (SDL.mouseMotionEventRelMotion dat) + ) + doConsume es + SDL.MouseButtonEvent dat -> do + partEmit am (MsgMouseButton + ts + (SDL.mouseButtonEventWindow dat) + (SDL.mouseButtonEventWhich dat) + (SDL.mouseButtonEventButton dat) + (SDL.mouseButtonEventClicks dat) + (unP $ SDL.mouseButtonEventPos dat) + ) + doConsume es + SDL.MouseWheelEvent dat -> do + partEmit am (MsgMouseWheel + ts + (SDL.mouseWheelEventWindow dat) + (SDL.mouseWheelEventWhich dat) + (SDL.mouseWheelEventPos dat) + (SDL.mouseWheelEventDirection dat) + ) + doConsume es + _ -> fmap (e :) (doConsume es) diff --git a/src/Affection/Subsystems/AffectionWindow.hs b/src/Affection/Subsystems/AffectionWindow.hs new file mode 100644 --- /dev/null +++ b/src/Affection/Subsystems/AffectionWindow.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +module Affection.Subsystems.AffectionWindow where + +import Affection.Types +import Affection.Util +import Affection.MessageBus +import Affection.Subsystems.Class + +import Control.Concurrent.STM as STM +import Control.Monad.IO.Class (liftIO) + +import qualified SDL + +consumeSDLWindowEvents + :: (Participant aw WindowMessage us) + => aw + -> [SDL.EventPayload] + -> Affection us [SDL.EventPayload] +consumeSDLWindowEvents aw = doConsume + where + doConsume [] = return [] + doConsume (e:es) = do + ts <- getElapsedTime + case e of + SDL.WindowShownEvent (SDL.WindowShownEventData window) -> do + partEmit aw (MsgWindowShow ts window) + doConsume es + SDL.WindowHiddenEvent (SDL.WindowHiddenEventData window) -> do + partEmit aw (MsgWindowHide ts window) + doConsume es + SDL.WindowExposedEvent (SDL.WindowExposedEventData window) -> do + partEmit aw (MsgWindowExpose ts window) + doConsume es + SDL.WindowMovedEvent (SDL.WindowMovedEventData window (SDL.P newPos)) -> do + partEmit aw (MsgWindowMove ts window newPos) + doConsume es + SDL.WindowResizedEvent (SDL.WindowResizedEventData window newSize) -> do + partEmit aw (MsgWindowResize ts window newSize) + doConsume es + SDL.WindowSizeChangedEvent (SDL.WindowSizeChangedEventData window) -> do + partEmit aw (MsgWindowSizeChange ts window) + doConsume es + SDL.WindowMinimizedEvent (SDL.WindowMinimizedEventData window) -> do + partEmit aw (MsgWindowMinimize ts window) + doConsume es + SDL.WindowMaximizedEvent (SDL.WindowMaximizedEventData window) -> do + partEmit aw (MsgWindowMaximize ts window) + doConsume es + SDL.WindowRestoredEvent (SDL.WindowRestoredEventData window) -> do + partEmit aw (MsgWindowRestore ts window) + doConsume es + SDL.WindowGainedMouseFocusEvent (SDL.WindowGainedMouseFocusEventData window) -> do + partEmit aw (MsgWindowGainMouseFocus ts window) + doConsume es + SDL.WindowLostMouseFocusEvent (SDL.WindowLostMouseFocusEventData window) -> do + partEmit aw (MsgWindowLoseMouseFocus ts window) + doConsume es + SDL.WindowGainedKeyboardFocusEvent (SDL.WindowGainedKeyboardFocusEventData window) -> do + partEmit aw (MsgWindowGainKeyboardFocus ts window) + doConsume es + SDL.WindowLostKeyboardFocusEvent (SDL.WindowLostKeyboardFocusEventData window) -> do + partEmit aw (MsgWindowLoseKeyboardFocus ts window) + doConsume es + SDL.WindowClosedEvent (SDL.WindowClosedEventData window) -> do + partEmit aw (MsgWindowClose ts window) + doConsume es + _ -> fmap (e :) (doConsume es) diff --git a/src/Affection/Subsystems/Class.hs b/src/Affection/Subsystems/Class.hs new file mode 100644 --- /dev/null +++ b/src/Affection/Subsystems/Class.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +module Affection.Subsystems.Class where + +import Affection.Types +import Affection.MessageBus + +import qualified SDL + +class SDLSubsystem s us where + consumeSDLEvents :: s -> [SDL.EventPayload] -> Affection us [SDL.EventPayload] diff --git a/src/Affection/Types.hs b/src/Affection/Types.hs --- a/src/Affection/Types.hs +++ b/src/Affection/Types.hs @@ -1,52 +1,57 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveFunctor #-} module Affection.Types - ( Affection - , AffectionData(..) - , AffectionConfig(..) - , AffectionState(..) - -- , AffectionDraw(..) - -- , Draw(..) - , AffectionStateInner - -- , AffectionDrawInner(..) - , InitComponents(..) - -- , Loop(..) - , RGBA(..) - , DrawType(..) - , DrawRequest(..) - , RequestPersist(..) - , Angle(..) - , ConvertAngle(..) - -- | Particle system - , Particle(..) - , ParticleSystem(..) - , ParticleStorage(..) - -- | Convenience exports - , liftIO - , SDL.WindowConfig(..) - , SDL.defaultWindow - -- | GEGL reexports - , G.GeglRectangle(..) - , G.GeglBuffer(..) - ) where + -- ( Affection + -- , AffectionData(..) + -- , AffectionConfig(..) + -- , AffectionState(..) + -- -- , AffectionDraw(..) + -- -- , Draw(..) + -- , AffectionStateInner + -- -- , AffectionDrawInner(..) + -- , InitComponents(..) + -- -- , Loop(..) + -- -- , RGBA(..) + -- , DrawType(..) + -- , DrawRequest(..) + -- , RequestPersist(..) + -- , Angle(..) + -- -- , ConvertAngle(..) + -- -- | Particle system + -- , Particle(..) + -- , ParticleSystem(..) + -- , ParticleStorage(..) + -- -- | Convenience exports + -- , liftIO + -- , SDL.WindowConfig(..) + -- , SDL.defaultWindow + -- -- | GEGL reexports + -- , G.GeglRectangle(..) + -- , G.GeglBuffer(..) + -- ) + where import qualified SDL.Init as SDL import qualified SDL.Video as SDL import qualified SDL.Event as SDL import qualified Data.Text as T -import Data.Map +import Data.Map.Strict as M -import qualified GEGL as G -import qualified BABL as B +-- import qualified GEGL as G +-- import qualified BABL as B import Control.Monad.IO.Class import Control.Monad.State import qualified Control.Monad.Parallel as MP + +import System.Clock (TimeSpec) -- import Control.Monad.Reader -- import Control.Concurrent.MVar import Foreign.Ptr (Ptr) +import Affection.MessageBus.Message + -- | Configuration for the aplication. needed at startup. data AffectionConfig us = AffectionConfig { initComponents :: InitComponents @@ -55,16 +60,20 @@ -- ^ Window title , windowConfig :: SDL.WindowConfig -- ^ Window configuration + , canvasSize :: Maybe (Int, Int) + -- ^ size of the texture canvas + , initScreenMode :: SDL.WindowMode + -- ^ Window mode to start in + , loadState :: IO us + -- ^ Provide your own load function to create this data. , preLoop :: Affection us () -- ^ Actions to be performed, before loop starts - , eventLoop :: SDL.EventPayload -> Affection us () + , eventLoop :: [SDL.EventPayload] -> Affection us () -- ^ Main update function. Takes fractions of a second as input. - , updateLoop :: Affection us () + , updateLoop :: Double -> Affection us () -- ^ Main update function. Takes fractions of a second as input. , drawLoop :: Affection us () -- ^ Function for updating graphics. - , loadState :: SDL.Surface -> IO us - -- ^ Provide your own load function to create this data. , cleanUp :: us -> IO () -- ^ Provide your own finisher function to clean your data. } @@ -80,35 +89,39 @@ { quitEvent :: Bool -- ^ Loop breaker. , userState :: us -- ^ State data provided by user , drawWindow :: SDL.Window -- ^ SDL window + , glContext :: SDL.GLContext -- ^ OpenGL rendering context , windowRenderer :: SDL.Renderer -- ^ Internal renderer of window - , drawSurface :: SDL.Surface -- ^ SDL surface - , drawFormat :: B.BablFormatPtr -- ^ Target format - , drawStack :: [DrawRequest] -- ^ Stack of 'DrawRequest's to be processed - , drawPixels :: Ptr () -- ^ Destination Pixel buffer + , drawTexture :: SDL.Texture -- ^ SDL Texture to draw to + -- , drawFormat :: B.BablFormatPtr -- ^ Target format + , screenMode :: SDL.WindowMode -- ^ current screen mode + -- , drawStack :: [DrawRequest] -- ^ Stack of 'DrawRequest's to be processed , drawDimensions :: (Int, Int) -- ^ Dimensions of target surface , drawStride :: Int -- ^ Stride of target buffer , drawCPP :: Int -- ^ Number of components per pixel , elapsedTime :: Double -- ^ Elapsed time in seconds - , dt :: Double -- ^ Elapsed time in seconds since last tick - } - --- | This datatype stores information about areas of a 'G.GeglBuffer' to be updated -data DrawRequest = DrawRequest - { requestArea :: G.GeglRectangle -- ^ The area to update - , requestBuffer :: G.GeglBuffer -- ^ Buffer to draw - , requestPersist :: RequestPersist -- ^ Shall the drawRequest persist + , deltaTime :: Double -- ^ Elapsed time in seconds since last tick + , sysTime :: TimeSpec -- ^ System time (NOT the time on the clock) + , pausedTime :: Bool -- ^ Should the update loop be executed? + -- , messageChannel :: Channel msg -- ^ The main broadcast channel to duplicate all others from } -data RequestPersist - = Persist - | Kill (Maybe G.GeglNode) - --- | A type for storing 'DrawRequest' results to be executed frequently. TODO -data DrawAsset = DrawAsset +-- -- | This datatype stores information about areas of a 'G.GeglBuffer' to be updated +-- data DrawRequest = DrawRequest +-- { requestArea :: G.GeglRectangle -- ^ The area to update +-- , requestBuffer :: G.GeglBuffer -- ^ Buffer to draw +-- , requestPersist :: RequestPersist -- ^ Shall the drawRequest persist +-- } +-- +-- data RequestPersist +-- = Persist +-- | Kill (Maybe G.GeglNode) +-- +-- -- | A type for storing 'DrawRequest' results to be executed frequently. TODO +-- data DrawAsset = DrawAsset -- | Inner 'StateT' monad for the update state -- type AffectionStateInner us m a = StateT (AffectionData us) m a -type AffectionStateInner us m a = StateT us m a +type AffectionStateInner us a = StateT us a -- | Affection's state monad newtype AffectionState us m a = AffectionState @@ -140,12 +153,12 @@ -- { runLoop :: f -> (a, f) } -- deriving (Functor, Applicative, Monad, MonadState (Loop f)) -data RGBA = RGBA - { r :: Int - , g :: Int - , b :: Int - , a :: Int - } +-- data RGBA = RGBA +-- { r :: Int +-- , g :: Int +-- , b :: Int +-- , a :: Int +-- } -- | Type for defining the draw type of draw functions data DrawType @@ -156,63 +169,65 @@ { lineWidth :: Int -- ^ Width of line in pixels } --- | Type for defining angles -data Angle - = Rad Double -- ^ Angle in radians - | Deg Double -- ^ Angle in degrees - deriving (Show) - --- | Typeclass for converting Angles from 'Deg' to 'Rad' and vice versa. -class ConvertAngle a where - toRad :: a -> a -- Convert to 'Rad' - toDeg :: a -> a -- Convert to 'Deg' - -instance ConvertAngle Angle where - toRad (Deg x) = Rad $ x * pi / 180 - toRad x = x - - toDeg (Rad x) = Deg $ x * 180 / pi - toDeg x = x - -instance Eq Angle where - (==) (Deg x) (Deg y) = x == y - (==) (Rad x) (Rad y) = x == y - (==) dx@(Deg _) ry@(Rad _) = dx == toDeg ry - (==) rx@(Rad _) dy@(Deg _) = toDeg rx == dy - --- | A single particle -data Particle = Particle - { particleTimeToLive :: Double - -- ^ Time to live in seconds - , particleCreation :: Double - -- ^ Creation time of particle in seconds form program start - , particlePosition :: (Double, Double) - -- ^ Position of particle on canvas - , particleRotation :: Angle - -- ^ Particle rotation - , particleVelocity :: (Int, Int) - -- ^ particle velocity as vector of pixels per second - , particlePitchRate :: Angle - -- ^ Rotational velocity of particle in angle per second - , particleRootNode :: G.GeglNode - -- ^ Root 'G.GeglNode' of 'Particle' - , particleNodeGraph :: Map String G.GeglNode - -- ^ Node Graph of 'G.GeglNodes' per particle - , particleStackCont :: G.GeglNode - -- ^ 'G.GeglNode' to connect other 'Particle's to - , particleDrawFlange :: G.GeglNode - -- ^ 'G.GeglNode' to connect draw actions to - } deriving (Eq) +type Angle = Double --- | The particle system -data ParticleSystem = ParticleSystem - { partSysParts :: ParticleStorage - , partSysNode :: G.GeglNode - , partSysBuffer :: G.GeglBuffer - } +-- -- | Type for defining angles +-- data Angle +-- = Rad Double -- ^ Angle in radians +-- | Deg Double -- ^ Angle in degrees +-- deriving (Show) +-- +-- -- | Typeclass for converting Angles from 'Deg' to 'Rad' and vice versa. +-- class ConvertAngle a where +-- toRad :: a -> a -- Convert to 'Rad' +-- toDeg :: a -> a -- Convert to 'Deg' +-- +-- instance ConvertAngle Angle where +-- toRad (Deg x) = Rad $ x * pi / 180 +-- toRad x = x +-- +-- toDeg (Rad x) = Deg $ x * 180 / pi +-- toDeg x = x +-- +-- instance Eq Angle where +-- (==) (Deg x) (Deg y) = x == y +-- (==) (Rad x) (Rad y) = x == y +-- (==) dx@(Deg _) ry@(Rad _) = dx == toDeg ry +-- (==) rx@(Rad _) dy@(Deg _) = toDeg rx == dy --- | The particle storage datatype -data ParticleStorage = ParticleStorage - { partStorLatest :: Maybe Particle -- ^ The particle stored last - , partStorList :: [Particle] -- ^ List of particles in ascending order of remaining lifetime - } +-- -- | A single particle +-- data Particle = Particle +-- { particleTimeToLive :: Double +-- -- ^ Time to live in seconds +-- , particleCreation :: Double +-- -- ^ Creation time of particle in seconds form program start +-- , particlePosition :: (Double, Double) +-- -- ^ Position of particle on canvas +-- , particleRotation :: Angle +-- -- ^ Particle rotation +-- , particleVelocity :: (Int, Int) +-- -- ^ particle velocity as vector of pixels per second +-- , particlePitchRate :: Angle +-- -- ^ Rotational velocity of particle in angle per second +-- , particleRootNode :: G.GeglNode +-- -- ^ Root 'G.GeglNode' of 'Particle' +-- , particleNodeGraph :: Map String G.GeglNode +-- -- ^ Node Graph of 'G.GeglNodes' per particle +-- , particleStackCont :: G.GeglNode +-- -- ^ 'G.GeglNode' to connect other 'Particle's to +-- , particleDrawFlange :: G.GeglNode +-- -- ^ 'G.GeglNode' to connect draw actions to +-- } deriving (Eq) +-- +-- -- | The particle system +-- data ParticleSystem = ParticleSystem +-- { partSysParts :: ParticleStorage +-- , partSysNode :: G.GeglNode +-- , partSysBuffer :: G.GeglBuffer +-- } +-- +-- -- | The particle storage datatype +-- data ParticleStorage = ParticleStorage +-- { partStorLatest :: Maybe Particle -- ^ The particle stored last +-- , partStorList :: [Particle] -- ^ List of particles in ascending order of remaining lifetime +-- } diff --git a/src/Affection/Util.hs b/src/Affection/Util.hs new file mode 100644 --- /dev/null +++ b/src/Affection/Util.hs @@ -0,0 +1,72 @@ +module Affection.Util +where + +import Affection.Types +import Affection.Logging + +import qualified SDL + +import System.Clock + +import Control.Monad.State + +-- Prehandle SDL events in case any window events occur +preHandleEvents :: [SDL.Event] -> Affection us [SDL.EventPayload] +preHandleEvents evs = + return $ map SDL.eventPayload evs + +-- | Return the userstate to the user +getAffection :: Affection us us +getAffection = do + ad <- get + return $ userState ad + +-- | Put altered user state back +putAffection + :: us -- User state + -> Affection us () +putAffection us = do + ad <- get + put $ ad + { userState = us } + +-- | block a thread for a specified amount of time +delaySec + :: Int -- ^ Number of seconds + -> IO () +delaySec dur = SDL.delay (fromIntegral $ dur * 1000) + +-- | Get time since start but always the same in the current tick. +getElapsedTime :: Affection us Double +getElapsedTime = + elapsedTime <$> get + +getDelta :: Affection us Double +getDelta = + deltaTime <$> get + +quit :: Affection us () +quit = do + ad <- get + put $ ad { quitEvent = True } + +-- | Toggle the Screen mode between 'SDL.Windowed' and 'SDL.FullscreenDesktop'. +-- Pauses the Engine in the process. +toggleScreen :: Affection us () +toggleScreen = do + ad <- get + newMode <- case screenMode ad of + SDL.Windowed -> do + SDL.setWindowMode (drawWindow ad) SDL.FullscreenDesktop + return SDL.FullscreenDesktop + SDL.FullscreenDesktop -> do + SDL.setWindowMode (drawWindow ad) SDL.Windowed + return SDL.Windowed + x -> do + liftIO $ logIO Warn ("Unknown Screen mode: " ++ show x) + return x + now <- liftIO $ getTime Monotonic + put ad + { sysTime = now + , screenMode = newMode + }