affection 0.0.0.6 → 0.0.0.7
raw patch · 30 files changed
+1030/−1472 lines, 30 filesdep +OpenGLdep +bytestringdep +lineardep −babldep −gegldep −randomdep ~base
Dependencies added: OpenGL, bytestring, linear, stm, uuid
Dependencies removed: babl, gegl, random
Dependency ranges changed: base
Files
- ChangeLog.md +5/−0
- affection.cabal +150/−84
- examples/example00.hs +119/−98
- examples/example01.hs +0/−109
- examples/example02.1.hs +0/−169
- examples/example02.hs +0/−141
- examples/example03.hs +0/−200
- src/Affection.hs +83/−135
- src/Affection/Actor.hs +0/−12
- src/Affection/Draw.hs +0/−201
- src/Affection/Logging.hs +40/−0
- src/Affection/MessageBus.hs +10/−0
- src/Affection/MessageBus/Class.hs +66/−0
- src/Affection/MessageBus/Message.hs +8/−0
- src/Affection/MessageBus/Message/Class.hs +6/−0
- src/Affection/MessageBus/Message/KeyboardMessage.hs +19/−0
- src/Affection/MessageBus/Message/MouseMessage.hs +42/−0
- src/Affection/MessageBus/Message/WindowMessage.hs +89/−0
- src/Affection/MessageBus/Util.hs +3/−0
- src/Affection/MouseInteractable.hs +4/−4
- src/Affection/Particle.hs +0/−154
- src/Affection/Property.hs +0/−46
- src/Affection/StateMachine.hs +1/−1
- src/Affection/Subsystems.hs +8/−0
- src/Affection/Subsystems/AffectionKeyboard.hs +35/−0
- src/Affection/Subsystems/AffectionMouse.hs +57/−0
- src/Affection/Subsystems/AffectionWindow.hs +69/−0
- src/Affection/Subsystems/Class.hs +11/−0
- src/Affection/Types.hs +133/−118
- src/Affection/Util.hs +72/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for affection++## 0.0.0.7 -- 2017-12-23++* Release with working scaffold for engine subsystems.
affection.cabal view
@@ -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
examples/example00.hs view
@@ -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 ()
− examples/example01.hs
@@ -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 ()
− examples/example02.1.hs
@@ -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 ()
− examples/example02.hs
@@ -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 ()
− examples/example03.hs
@@ -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
src/Affection.hs view
@@ -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"
− src/Affection/Actor.hs
@@ -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- }
− src/Affection/Draw.hs
@@ -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)
+ src/Affection/Logging.hs view
@@ -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 ()
+ src/Affection/MessageBus.hs view
@@ -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
+ src/Affection/MessageBus/Class.hs view
@@ -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
+ src/Affection/MessageBus/Message.hs view
@@ -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
+ src/Affection/MessageBus/Message/Class.hs view
@@ -0,0 +1,6 @@+module Affection.MessageBus.Message.Class where++import Data.Word (Word32(..))++class Message msg where+ msgTime :: msg -> Double
+ src/Affection/MessageBus/Message/KeyboardMessage.hs view
@@ -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
+ src/Affection/MessageBus/Message/MouseMessage.hs view
@@ -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
+ src/Affection/MessageBus/Message/WindowMessage.hs view
@@ -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
+ src/Affection/MessageBus/Util.hs view
@@ -0,0 +1,3 @@+module Affection.MessageBus.Util where++-- zuru zuru
src/Affection/MouseInteractable.hs view
@@ -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
− src/Affection/Particle.hs
@@ -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
− src/Affection/Property.hs
@@ -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
src/Affection/StateMachine.hs view
@@ -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 ()
+ src/Affection/Subsystems.hs view
@@ -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
+ src/Affection/Subsystems/AffectionKeyboard.hs view
@@ -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)
+ src/Affection/Subsystems/AffectionMouse.hs view
@@ -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)
+ src/Affection/Subsystems/AffectionWindow.hs view
@@ -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)
+ src/Affection/Subsystems/Class.hs view
@@ -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]
src/Affection/Types.hs view
@@ -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+-- }
+ src/Affection/Util.hs view
@@ -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+ }