affection (empty) → 0.0.0.0
raw patch · 11 files changed
+1548/−0 lines, 11 filesdep +affectiondep +babldep +basesetup-changed
Dependencies added: affection, babl, base, clock, containers, gegl, glib, linear, monad-loops, mtl, random, sdl2, text
Files
- LICENSE +165/−0
- Setup.hs +2/−0
- affection.cabal +152/−0
- examples/example00.hs +111/−0
- examples/example01.hs +105/−0
- examples/example02.hs +125/−0
- examples/example03.hs +206/−0
- src/Affection.hs +132/−0
- src/Affection/Draw.hs +176/−0
- src/Affection/Particle.hs +169/−0
- src/Affection/Types.hs +205/−0
+ LICENSE view
@@ -0,0 +1,165 @@+ GNU LESSER GENERAL PUBLIC LICENSE+ Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.+++ This version of the GNU Lesser General Public License incorporates+the terms and conditions of version 3 of the GNU General Public+License, supplemented by the additional permissions listed below.++ 0. Additional Definitions.++ As used herein, "this License" refers to version 3 of the GNU Lesser+General Public License, and the "GNU GPL" refers to version 3 of the GNU+General Public License.++ "The Library" refers to a covered work governed by this License,+other than an Application or a Combined Work as defined below.++ An "Application" is any work that makes use of an interface provided+by the Library, but which is not otherwise based on the Library.+Defining a subclass of a class defined by the Library is deemed a mode+of using an interface provided by the Library.++ A "Combined Work" is a work produced by combining or linking an+Application with the Library. The particular version of the Library+with which the Combined Work was made is also called the "Linked+Version".++ The "Minimal Corresponding Source" for a Combined Work means the+Corresponding Source for the Combined Work, excluding any source code+for portions of the Combined Work that, considered in isolation, are+based on the Application, and not on the Linked Version.++ The "Corresponding Application Code" for a Combined Work means the+object code and/or source code for the Application, including any data+and utility programs needed for reproducing the Combined Work from the+Application, but excluding the System Libraries of the Combined Work.++ 1. Exception to Section 3 of the GNU GPL.++ You may convey a covered work under sections 3 and 4 of this License+without being bound by section 3 of the GNU GPL.++ 2. Conveying Modified Versions.++ If you modify a copy of the Library, and, in your modifications, a+facility refers to a function or data to be supplied by an Application+that uses the facility (other than as an argument passed when the+facility is invoked), then you may convey a copy of the modified+version:++ a) under this License, provided that you make a good faith effort to+ ensure that, in the event an Application does not supply the+ function or data, the facility still operates, and performs+ whatever part of its purpose remains meaningful, or++ b) under the GNU GPL, with none of the additional permissions of+ this License applicable to that copy.++ 3. Object Code Incorporating Material from Library Header Files.++ The object code form of an Application may incorporate material from+a header file that is part of the Library. You may convey such object+code under terms of your choice, provided that, if the incorporated+material is not limited to numerical parameters, data structure+layouts and accessors, or small macros, inline functions and templates+(ten or fewer lines in length), you do both of the following:++ a) Give prominent notice with each copy of the object code that the+ Library is used in it and that the Library and its use are+ covered by this License.++ b) Accompany the object code with a copy of the GNU GPL and this license+ document.++ 4. Combined Works.++ You may convey a Combined Work under terms of your choice that,+taken together, effectively do not restrict modification of the+portions of the Library contained in the Combined Work and reverse+engineering for debugging such modifications, if you also do each of+the following:++ a) Give prominent notice with each copy of the Combined Work that+ the Library is used in it and that the Library and its use are+ covered by this License.++ b) Accompany the Combined Work with a copy of the GNU GPL and this license+ document.++ c) For a Combined Work that displays copyright notices during+ execution, include the copyright notice for the Library among+ these notices, as well as a reference directing the user to the+ copies of the GNU GPL and this license document.++ d) Do one of the following:++ 0) Convey the Minimal Corresponding Source under the terms of this+ License, and the Corresponding Application Code in a form+ suitable for, and under terms that permit, the user to+ recombine or relink the Application with a modified version of+ the Linked Version to produce a modified Combined Work, in the+ manner specified by section 6 of the GNU GPL for conveying+ Corresponding Source.++ 1) Use a suitable shared library mechanism for linking with the+ Library. A suitable mechanism is one that (a) uses at run time+ a copy of the Library already present on the user's computer+ system, and (b) will operate properly with a modified version+ of the Library that is interface-compatible with the Linked+ Version.++ e) Provide Installation Information, but only if you would otherwise+ be required to provide such information under section 6 of the+ GNU GPL, and only to the extent that such information is+ necessary to install and execute a modified version of the+ Combined Work produced by recombining or relinking the+ Application with a modified version of the Linked Version. (If+ you use option 4d0, the Installation Information must accompany+ the Minimal Corresponding Source and Corresponding Application+ Code. If you use option 4d1, you must provide the Installation+ Information in the manner specified by section 6 of the GNU GPL+ for conveying Corresponding Source.)++ 5. Combined Libraries.++ You may place library facilities that are a work based on the+Library side by side in a single library together with other library+facilities that are not Applications and are not covered by this+License, and convey such a combined library under terms of your+choice, if you do both of the following:++ a) Accompany the combined library with a copy of the same work based+ on the Library, uncombined with any other library facilities,+ conveyed under the terms of this License.++ b) Give prominent notice with the combined library that part of it+ is a work based on the Library, and explaining where to find the+ accompanying uncombined form of the same work.++ 6. Revised Versions of the GNU Lesser General Public License.++ The Free Software Foundation may publish revised and/or new versions+of the GNU Lesser General Public License from time to time. Such new+versions will be similar in spirit to the present version, but may+differ in detail to address new problems or concerns.++ Each version is given a distinguishing version number. If the+Library as you received it specifies that a certain numbered version+of the GNU Lesser General Public License "or any later version"+applies to it, you have the option of following the terms and+conditions either of that published version or of any later version+published by the Free Software Foundation. If the Library as you+received it does not specify a version number of the GNU Lesser+General Public License, you may choose any version of the GNU Lesser+General Public License ever published by the Free Software Foundation.++ If the Library as you received it specifies that a proxy can decide+whether future versions of the GNU Lesser General Public License shall+apply, that proxy's public statement of acceptance of any version is+permanent authorization for you to choose that version for the+Library.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ affection.cabal view
@@ -0,0 +1,152 @@+name: affection++-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented.+-- http://www.haskell.org/haskellwiki/Package_versioning_policy+-- PVP summary: +-+------- breaking API changes+-- | | +----- non-breaking API additions+-- | | | +--- code changes with no API change+version: 0.0.0.0+synopsis: A simple Game Engine using SDL+description: See homepage for description.+homepage: https://github.com/nek0/affection#readme+license: LGPL-3+license-file: LICENSE+author: nek0+maintainer: nek0@chelnok.de+category: Game+build-type: Simple++-- Extra files to be distributed with the package, such as examples or a +-- README.+-- extra-source-files: ++cabal-version: >=1.10++source-repository head+ type: git+ location: https://github.com/nek0/affection++flag examples+ description: Build example programs+ default: False++library+ exposed-modules: Affection+ , Affection.Draw+ , Affection.Particle+ , Affection.Types+ default-extensions: OverloadedStrings++ -- Modules included in this library but not exported.+ -- other-modules: + + -- LANGUAGE extensions used by modules in this package.+ other-extensions: GADTs+ , KindSignatures+ , FlexibleInstances+ , MultiParamTypeClasses+ , UndecidableInstances+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall+ -- Other library packages from which modules are imported.+ build-depends: base >=4.9 && <4.10+ , sdl2+ , text+ , linear+ , mtl+ , gegl+ , babl+ , monad-loops+ , containers+ , clock+ , glib+ -- , sdl2-image++executable example00+ hs-source-dirs: examples+ main-is: example00.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 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 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+-- 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
+ examples/example00.hs view
@@ -0,0 +1,111 @@+{-# 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 (CInt(..))++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 ()+ , drawLoop = draw+ , updateLoop = update+ , loadState = load+ , cleanUp = clean+ }+ withAffection conf++data UserData = UserData+ { nodeGraph :: M.Map String G.GeglNode+ }++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+ [ G.Property "color1" $ G.PropertyColor $ G.RGBA 0.4 0.4 0.4 1+ , G.Property "color2" $ G.PropertyColor $ 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+ [ G.Property "string" $ G.PropertyString "Hello world!"+ , G.Property "color" $ G.PropertyColor $ G.RGBA 0 0 1 0.5+ , G.Property "size" $ G.PropertyDouble 40+ ]+ 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+ }++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++update :: Double -> Affection UserData ()+update sec = do+ traceM "updating"+ ad <- get+ ud@UserData{..} <- getAffection+ traceM $ (show $ 1 / sec) ++ " FPS"+ when (elapsedTime ad > 5) $+ put $ ad+ { quitEvent = True+ }++clean :: UserData -> IO ()+clean _ = return ()
+ examples/example01.hs view
@@ -0,0 +1,105 @@+{-# 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 ()+ , drawLoop = draw+ , updateLoop = update+ , loadState = load+ , cleanUp = clean+ }+ withAffection conf++data UserData = UserData+ { nodeGraph :: M.Map String G.GeglNode+ , foreground :: G.GeglBuffer+ }++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+ [ G.Property "color1" $ G.PropertyColor $ G.RGBA 0.4 0.4 0.4 1+ , G.Property "color2" $ G.PropertyColor $ 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"+ [ G.Property "buffer" $ G.PropertyBuffer 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"+ [ G.Property "width" $ G.PropertyDouble 800+ , G.Property "height" $ G.PropertyDouble 600+ ]+ 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+ }++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+ liftIO $ G.gegl_node_process $ nodeGraph M.! "sink"++update :: Double -> AffectionState (AffectionData UserData) IO ()+update sec = do+ traceM "updating"+ -- liftIO $ delaySec 5+ ad <- get+ ud@UserData{..} <- getAffection+ traceM $ (show $ 1 / sec) ++ " FPS"+ when (elapsedTime ad > 20) $+ put $ ad+ { quitEvent = True+ }++clean :: UserData -> IO ()+clean _ = return ()
+ examples/example02.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE RecordWildCards #-}++import Affection+import qualified SDL+import qualified GEGL as G+import qualified GEGL.FFI.Buffer as G+import qualified BABL as B+import qualified Data.Map.Strict as M++import Foreign.C.Types+import Foreign.Marshal.Utils (new)+import Foreign.Ptr (castPtr)++import Debug.Trace++main :: IO ()+main = do+ conf <- return $ AffectionConfig+ { initComponents = All+ , windowTitle = "Affection: example00"+ , windowConfig = SDL.defaultWindow+ , preLoop = return ()+ , drawLoop = draw+ , updateLoop = update+ , loadState = load+ , cleanUp = clean+ }+ withAffection conf++data UserData = UserData+ { nodeGraph :: M.Map String G.GeglNode+ , foreground :: G.GeglBuffer+ , coordinates :: Maybe (Int, Int)+ }++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+ [ G.Property "color1" $ G.PropertyColor $ G.RGBA 0.4 0.4 0.4 1+ , G.Property "color2" $ G.PropertyColor $ 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"+ [ 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+ ]+ 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)+ , ("crop" , crop)+ ]+ traceM "loading complete"+ return $ UserData+ { nodeGraph = myMap+ , foreground = buffer+ , coordinates = Nothing+ }++-- drawInit :: Affection UserData ()+-- drawInit = do+-- UserData{..} <- getAffection+-- present (nodeGraph M.! "over") foreground (GeglRectangle 0 0 800 600) True++draw :: Affection UserData ()+draw = do+ traceM "drawing"+ ad <- get+ UserData{..} <- getAffection+ SDL.V2 (CInt rw) (CInt rh) <- SDL.surfaceDimensions $ drawSurface ad+ let (w, h) = (fromIntegral rw, fromIntegral rh)+ liftIO $ clearArea foreground (GeglRectangle 0 0 w h)+ maybe (return ()) (\(x, y) ->+ drawRect+ (nodeGraph M.! "nop")+ (G.RGBA 1 0 0 0.5)+ (Fill)+ (G.GeglRectangle (x - 10) (y - 10) 20 20)+ foreground+ ) coordinates+ liftIO $ G.gegl_node_process $ nodeGraph M.! "sink"++update :: Double -> AffectionState (AffectionData UserData) IO ()+update sec = do+ traceM "updating"+ ad <- get+ ud <- getAffection+ traceM $ (show $ 1 / sec) ++ " FPS"+ ev <- liftIO $ SDL.pollEvent+ maybe (return ()) (\e ->+ case SDL.eventPayload e of+ SDL.MouseMotionEvent dat -> do+ let (SDL.P (SDL.V2 x y)) = SDL.mouseMotionEventPos dat+ putAffection $ ud+ { coordinates = Just (fromIntegral x, fromIntegral y)+ }+ SDL.WindowClosedEvent _ -> do+ traceM "seeya!"+ put $ ad+ { quitEvent = True+ }+ _ ->+ return ()+ ) ev++clean :: UserData -> IO ()+clean _ = return ()
+ examples/example03.hs view
@@ -0,0 +1,206 @@+{-# 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 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+ , drawLoop = draw+ , updateLoop = update+ , 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"+ checkerboard <- G.gegl_node_new_child root $ G.checkerboardOperation+ [ G.Property "color1" $ G.PropertyColor $ G.RGBA 0.4 0.4 0.4 1+ , G.Property "color2" $ G.PropertyColor $ 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"+ [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 [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)+ , ("crop" , crop)+ ]+ traceM "loading complete"+ return $ UserData+ { nodeGraph = myMap+ , foreground = buffer+ , partsys = ParticleSystem (ParticleStorage Nothing []) nop buffer+ }++drawInit :: Affection UserData ()+drawInit = do+ UserData{..} <- getAffection+ present (GeglRectangle 0 0 800 600) foreground True++draw :: Affection UserData ()+draw = do+ traceM "drawing"+ UserData{..} <- getAffection+ liftIO $ G.gegl_node_process $ nodeGraph M.! "sink"+ -- ad <- get+ -- ud <- getAffection+ -- drawParticles partDraw $ particles ud+ -- SDL.V2 (CInt rw) (CInt rh) <- SDL.surfaceDimensions $ drawSurface ad+ -- let (w, h) = (fromIntegral rw, fromIntegral rh)+ -- liftIO $ clearArea (foreground ud) (GeglRectangle 0 0 w h)+ -- maybe (return ()) (\(x, y) ->+ -- drawRect+ -- (foreground ud)+ -- (nodeGraph ud M.! "over")+ -- (G.RGBA 1 0 0 0.5)+ -- (Line 7)+ -- (G.GeglRectangle (x - 10) (y - 10) 20 20)+ -- ) $ coordinates ud++update :: Double -> AffectionState (AffectionData UserData) IO ()+update sec = do+ traceM "updating"+ ad <- get+ ud <- getAffection+ -- let newPart = updateParticles sec partUpd $ particles ud+ -- putAffection $ ud { particles = newPart }+ traceM $ (show $ 1 / sec) ++ " FPS"+ ev <- liftIO $ SDL.pollEvents+ mapM_ (\e ->+ case SDL.eventPayload e of+ SDL.MouseMotionEvent dat ->+ if SDL.ButtonLeft `elem` SDL.mouseMotionEventState dat+ then do+ 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)+ else+ return ()+ SDL.WindowClosedEvent _ -> do+ traceM "seeya!"+ put $ ad+ { quitEvent = True+ }+ _ ->+ return ()+ ) ev+ ud2 <- getAffection+ nps <- updateParticleSystem (partsys ud2) sec partUpd partDraw+ putAffection $ ud2 { partsys = nps }++clean :: UserData -> IO ()+clean _ = return ()++partUpd :: Double -> Particle -> Affection UserData Particle+partUpd sec p@Particle{..} = do+ let newX = (fst particlePosition) + sec * (fromIntegral $ fst particleVelocity)+ newY = (snd particlePosition) + sec * (fromIntegral $ snd particleVelocity)+ liftIO $ G.gegl_node_set (particleNodeGraph M.! "rect") $ G.Operation "gegl:rectangle"+ [ G.Property "x" $ G.PropertyDouble $ newX - 10+ , G.Property "y" $ G.PropertyDouble $ newY - 10+ ]+ return p+ { particlePosition = (newX, newY)+ }++partDraw :: G.GeglBuffer -> G.GeglNode -> Particle -> Affection UserData ()+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
@@ -0,0 +1,132 @@+{-# LANGUAGE RecordWildCards #-}+module Affection+ ( withAffection+ , getAffection+ , putAffection+ -- , withWindow+ -- , withDefaultWindow+ , delaySec+ , get+ , put+ , module A+ ) where++import qualified SDL+import qualified SDL.Internal.Numbered as SDL (toNumber)+import qualified SDL.Raw as Raw+import qualified GEGL as G++import qualified Data.Text as T+import Data.Maybe++import System.Clock++import Control.Monad.Loops+import Control.Monad.State+import Control.Concurrent.MVar++import Foreign.C.Types (CInt(..))+import Foreign.Storable (peek)++import Affection.Types as A+import Affection.Draw as A+import Affection.Particle as A++import qualified BABL as B++-- | Main function which bootstraps everything else.+withAffection+ :: AffectionConfig us -- ^ Configuration of the Game and its engine.+ -> IO ()+withAffection AffectionConfig{..} = do+ case initComponents of+ All ->+ SDL.initializeAll+ Only is ->+ SDL.initialize is+ G.gegl_init+ execTime <- newMVar =<< getTime Monotonic+ window <- SDL.createWindow windowTitle windowConfig+ oldSurf@(SDL.Surface ptr _) <- SDL.getWindowSurface window+ rawSurfacePtr <- Raw.convertSurfaceFormat ptr (SDL.toNumber SDL.ABGR8888) 0+ let surface = (flip SDL.Surface Nothing) rawSurfacePtr+ bablFormat = B.PixelFormat B.RGBA B.CFu8+ pixels <- SDL.surfacePixels surface+ format <- B.babl_format bablFormat+ SDL.V2 (CInt rw) (CInt rh) <- SDL.surfaceDimensions surface+ pixelFormat <- peek . Raw.surfaceFormat =<< peek rawSurfacePtr+ let (w, h) = (fromIntegral rw, fromIntegral rh)+ stride = fromIntegral (Raw.pixelFormatBytesPerPixel pixelFormat) * w+ cpp = B.babl_components_per_pixel bablFormat+ initContainer <- (\x -> AffectionData+ { quitEvent = False+ , userState = x+ , drawWindow = window+ , drawSurface = surface+ , drawFormat = format+ , drawStack = []+ , elapsedTime = 0+ }) <$> loadState surface+ (_, nState) <- runStateT ( A.runState $ do+ preLoop+ liftIO $ SDL.surfaceBlit surface Nothing oldSurf Nothing+ whileM_ (do+ current <- get+ return $ not $ A.quitEvent current+ )+ (do+ -- Measure time difference form last run+ now <- liftIO $ getTime Monotonic+ lastTime <- liftIO $ fromMaybe now <$> tryReadMVar execTime+ -- get state+ ad <- get+ -- clean draw requests from last run+ mapM_ (invalidateDrawRequest pixels stride cpp) $ drawStack ad+ -- compute dt and update elapsedTime+ let dt = (fromIntegral $ toNanoSecs $ diffTimeSpec lastTime now) / (fromIntegral 10 ^ 9)+ put $ ad+ { drawStack = []+ , elapsedTime = elapsedTime ad + dt+ }+ -- execute user defined update loop+ updateLoop dt+ -- execute user defined draw loop+ drawLoop+ -- handle all new draw requests+ ad2 <- get+ clear <- catMaybes <$> mapM (handleDrawRequest pixels stride cpp) (drawStack ad2)+ -- save all draw requests to clear in next run+ put $ ad2+ { drawStack = clear }+ -- blit surface and update window+ liftIO $ SDL.surfaceBlit surface Nothing oldSurf Nothing+ liftIO $ SDL.updateWindowSurface $ drawWindow ad2+ -- save new time+ _ <- liftIO $ swapMVar execTime $ now+ return ()+ )+ ) initContainer+ G.gegl_exit+ cleanUp $ userState nState+ SDL.quit++-- | 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)
+ src/Affection/Draw.hs view
@@ -0,0 +1,176 @@+{-# LANGUAGE RecordWildCards, BangPatterns #-}++-- | Module for drawing primitives+module Affection.Draw+ ( drawRect+ -- , clear+ , handleDrawRequest+ , invalidateDrawRequest+ , present+ , clearArea+ ) where++import Affection.Types++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 Yes+ put ad+ { drawStack = (DrawRequest rect buf k) : drawStack 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+ liftIO $ SDL.lockSurface surf+ liftIO $ G.gegl_buffer_get+ requestBuffer+ (Just requestArea)+ 1+ (Just $ drawFormat ad)+ (pixels `plusPtr`+ (rectangleX requestArea * cpp + rectangleY requestArea * stride))+ stride+ G.GeglAbyssNone+ liftIO $ SDL.unlockSurface surf+ -- liftIO $ SDL.updateWindowSurface $ drawWindow ad+ case requestPersist of+ Yes ->+ 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+ let surf = drawSurface ad+ liftIO $ clearArea requestBuffer requestArea+ liftIO $ SDL.lockSurface surf+ liftIO $ G.gegl_buffer_get+ requestBuffer+ (Just requestArea)+ 1+ (Just $ drawFormat ad)+ (pixels `plusPtr`+ (rectangleX requestArea * cpp + rectangleY requestArea * stride))+ stride+ G.GeglAbyssNone+ liftIO $ SDL.unlockSurface surf+ 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
+ src/Affection/Particle.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE RecordWildCards #-}++-- | This module introduces a simple particle system to Affection+module Affection.Particle+ ( updateParticle+ , drawParticles+ , updateParticleSystem+ , insertParticle+ ) where++import Affection.Types++import Control.Monad+import Control.Monad.State (get)++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 a single 'Particle'+ -- This Function should take the elapsed time+ -- in seconds and the initial particle as arguments.+ -- -> [Maybe Particle]+ -> Particle+ -- ^ 'Particle' to be processed+ -- -> Affection us [Maybe Particle]+ -> Affection us (Maybe Particle)+ -- ^ resulting 'Particle'+updateParticle time funct pa = do+ now <- elapsedTime <$> get+ if particleCreation pa + particleTimeToLive pa < now+ then do+ -- mproducer <- liftIO $ G.gegl_node_get_producer+ -- (particleStackCont pa)+ -- "input"+ -- case mproducer of+ -- Just (producer, padname) -> do+ -- consumers <- liftIO $ G.gegl_node_get_consumers+ -- (particleStackCont pa)+ -- "output"+ -- liftIO $ mapM_ (\(node, inpad)-> G.gegl_node_connect_to+ -- producer+ -- padname+ -- node+ -- inpad+ -- ) consumers+ -- Nothing -> return ()+ liftIO $ G.gegl_node_drop $ particleRootNode pa+ return $ Nothing+ else do+ np <- Just <$> funct time pa+ return $ np+-- updateParticle time funct acc@[p] pa = do+-- now <- elapsedTime <$> get+-- if particleCreation pa + particleTimeToLive pa > now+-- then do+-- liftIO $ G.gegl_node_drop $ particleRootNode pa+-- return $ Nothing : acc+-- else do+-- when (not $ isNothing p) $ do+-- -- liftIO $ traceIO "linking second node in list"+-- liftIO $ G.gegl_node_link+-- (particleStackCont pa)+-- (particleStackCont $ fromJust p)+-- np <- Just <$> funct time pa+-- return $ np : acc+-- updateParticle time funct acc@(p:ps) pa = do+-- now <- elapsedTime <$> get+-- if particleCreation pa + particleTimeToLive pa > now+-- then do+-- liftIO $ G.gegl_node_drop $ particleRootNode pa+-- return $ Nothing : acc+-- else do+-- when (isNothing p) $ do+-- let mnl = nextLiving ps+-- maybe+-- (return ())+-- (\nl -> do+-- -- liftIO $ traceIO "linking nth node on list"+-- liftIO $ G.gegl_node_link (particleStackCont pa) (particleStackCont nl))+-- mnl+-- np <- Just <$> funct time pa+-- return $ np : acc++-- | 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+ -- if isNothing p+ -- then nextLiving ps+ -- else p++drawParticles+ :: (Particle -> Affection us ())+ -> [Particle]+ -> Affection us ()+drawParticles = mapM_++updateParticleSystem+ :: ParticleSystem+ -> Double+ -> (Double -> Particle -> Affection us Particle)+ -> (G.GeglBuffer -> G.GeglNode -> Particle -> Affection us ())+ -> Affection us ParticleSystem+updateParticleSystem sys sec upd draw = do+ x <- catMaybes <$> mapM (updateParticle sec upd) (partStorList $ partSysParts sys)+ -- x <- catMaybes <$> foldM (updateParticle sec upd) [] (reverse $ psParts sys)+ when (not $ null x) $ do+ liftIO $ G.gegl_node_link_many $ map particleStackCont (partStorList $ partSysParts sys)+ -- liftIO $ traceIO "linking last node to output"+ liftIO $ G.gegl_node_link (particleStackCont $ last x) (partSysNode sys)+ mapM_ (draw (partSysBuffer sys) (partSysNode sys)) x+ return $ sys+ { partSysParts = (partSysParts sys)+ { partStorList = x+ , partStorLatest =+ if null x+ then Nothing+ else partStorLatest (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+ when (not $ isNothing $ partStorLatest $ partSysParts ps) $ + liftIO $ G.gegl_node_link+ (particleStackCont p)+ (particleStackCont $ fromJust $ partStorLatest $ partSysParts ps)+ 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+ then p : [np]+ else np : [p]+chronoInsert now l@(p:ps) np =+ if now + particleTimeToLive p < particleCreation np+ then p : chronoInsert now ps np+ else np : l
+ src/Affection/Types.hs view
@@ -0,0 +1,205 @@+{-# 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++import qualified SDL.Init as SDL+import qualified SDL.Video as SDL+import qualified Data.Text as T+import Data.Map++import qualified GEGL as G+import qualified BABL as B++import Control.Monad.IO.Class+import Control.Monad.State+-- import Control.Monad.Reader++-- import Control.Concurrent.MVar++-- | Configuration for the aplication. needed at startup.+data AffectionConfig us = AffectionConfig+ { initComponents :: InitComponents+ -- ^ SDL components to initialize at startup+ , windowTitle :: T.Text+ -- ^ Window title+ , windowConfig :: SDL.WindowConfig+ -- ^ Window configuration+ , preLoop :: Affection us ()+ -- ^ Actions to be performed, before loop starts+ , drawLoop :: Affection us ()+ -- ^ Function for updating graphics.+ , updateLoop :: Double -> Affection us ()+ -- ^ Main update function. Takes fractions of a second as input.+ , 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.+ }++-- | Components to initialize in SDL.+data InitComponents+ = All+ | Only [SDL.InitFlag]++-- | Main type for defining the look, feel and action of the whole application.+data AffectionData us = AffectionData+ -- { affectionConfig :: AffectionConfig us -- ^ Application configuration.+ { quitEvent :: Bool -- ^ Loop breaker.+ , userState :: us -- ^ State data provided by user+ , drawWindow :: SDL.Window -- ^ SDL window+ , drawSurface :: SDL.Surface -- ^ SDL surface+ , drawFormat :: B.BablFormatPtr -- ^ Target format+ , drawStack :: [DrawRequest] -- ^ Stack of 'DrawRequest's to be processed+ , clearStack :: [DrawRequest] -- ^ Stack of 'DrawRequest's to be invalidated+ , elapsedTime :: Double -- ^ Elapsed time in seconds+ }++-- | 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+ = Yes+ | 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++-- | Affection's state monad+newtype AffectionState us m a = AffectionState+ { runState :: AffectionStateInner us m a }+ deriving (Functor, Applicative, Monad, MonadIO, MonadState us)++type Affection us a = AffectionState (AffectionData us) IO a++-- -- | Inner 'StateT' monad of Affection+-- type AffectionInner us od a = StateT (AffectionState us od) IO a+-- +-- -- | Affection state monad+-- newtype Affection us od a = Affection+-- { runAffection :: AffectionInner us od a }+-- deriving (Functor, Applicative, Monad, MonadState (AffectionState us od))+-- +-- -- | Inner drawing monad of Affection.+-- type AffectionDrawInner ds a = ReaderT (Draw ds) a+-- +-- -- | Affectiondrawinf reader monad.+-- newtype AffectionDraw ds a = AffectionDraw+-- { runDraw :: (ds -> a) }+-- deriving (Functor, Applicative, Monad, MonadReader ds)+-- +-- -- | Loop state monad to hold elapsed time per frame+-- newtype Loop f a = Loop+-- { runLoop :: f -> (a, f) }+-- deriving (Functor, Applicative, Monad, MonadState (Loop f))++data RGBA = RGBA+ { r :: Int+ , g :: Int+ , b :: Int+ , a :: Int+ }++-- | Type for defining the draw type of draw functions+data DrawType+ -- | Fill the specified area completely with color+ = Fill+ -- | only draw the outline of the area+ | Line+ { 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+ }++-- | 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+ }