diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,165 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/affection.cabal b/affection.cabal new file mode 100644 --- /dev/null +++ b/affection.cabal @@ -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 diff --git a/examples/example00.hs b/examples/example00.hs new file mode 100644 --- /dev/null +++ b/examples/example00.hs @@ -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 () diff --git a/examples/example01.hs b/examples/example01.hs new file mode 100644 --- /dev/null +++ b/examples/example01.hs @@ -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 () diff --git a/examples/example02.hs b/examples/example02.hs new file mode 100644 --- /dev/null +++ b/examples/example02.hs @@ -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 () diff --git a/examples/example03.hs b/examples/example03.hs new file mode 100644 --- /dev/null +++ b/examples/example03.hs @@ -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 diff --git a/src/Affection.hs b/src/Affection.hs new file mode 100644 --- /dev/null +++ b/src/Affection.hs @@ -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) diff --git a/src/Affection/Draw.hs b/src/Affection/Draw.hs new file mode 100644 --- /dev/null +++ b/src/Affection/Draw.hs @@ -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 diff --git a/src/Affection/Particle.hs b/src/Affection/Particle.hs new file mode 100644 --- /dev/null +++ b/src/Affection/Particle.hs @@ -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 diff --git a/src/Affection/Types.hs b/src/Affection/Types.hs new file mode 100644 --- /dev/null +++ b/src/Affection/Types.hs @@ -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 + }