From 8d20ab193bd9a0fa5ced11f7393bb01f4351c5a8 Mon Sep 17 00:00:00 2001 From: nek0 Date: Tue, 25 Sep 2018 00:17:59 +0200 Subject: [PATCH] pre-release cleanup part I --- src/Affection/Actor.hs | 62 ---------- src/Affection/Animation.hs | 49 -------- src/Affection/Draw.hs | 240 ------------------------------------- src/Affection/Particle.hs | 163 ------------------------- src/Affection/Property.hs | 46 ------- 5 files changed, 560 deletions(-) delete mode 100644 src/Affection/Actor.hs delete mode 100644 src/Affection/Animation.hs delete mode 100644 src/Affection/Draw.hs delete mode 100644 src/Affection/Particle.hs delete mode 100644 src/Affection/Property.hs diff --git a/src/Affection/Actor.hs b/src/Affection/Actor.hs deleted file mode 100644 index 0f98598..0000000 --- a/src/Affection/Actor.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - --- | This module implements the Actor, a Datastructure binding a 'G.GeglNode' --- to a game asset -module Affection.Actor - ( Actor(..) - , ActorProperty(..) - , updateProperties - , applyProperties - , getProperty - ) where - -import qualified GEGL as G - -import qualified Data.Map.Strict as M -import Data.List -import qualified Control.Monad.Parallel as MP - -import Affection.Types - -data (Show a, Ord a) => Actor a = Actor - { actorProperties :: [ActorProperty a] - , actorNodes :: M.Map a G.GeglNode - , actorFlange :: G.GeglNode - } deriving (Show, Eq) - -data (Show a, Ord a) => ActorProperty a = ActorProperty - { apName :: String - , apValue :: G.PropertyValue - , apMapping :: Maybe (a, String) - } deriving (Show, Eq) - -updateProperties :: (Show a, Ord a) => [G.Property] -> Actor a -> Actor a -updateProperties ps act@Actor{..} = - act - { actorProperties = - foldl (\acc (G.Property name val) -> newProp name val acc) actorProperties ps - } - where - newProp name val acc = nubBy (\a b -> apName a == apName b) $ (getProp name) - { apValue = val - } : acc - getProp n = getProp' n actorProperties - getProp' n [] = error $ "no ActorProperty found: " ++ n - getProp' n (p:ps) - | apName p == n = p - | otherwise = getProp' n ps - -applyProperties :: (Show a, Ord a) => Actor a -> Affection us () -applyProperties Actor{..} = - MP.mapM_ (\ActorProperty{..} -> - maybe (return ()) (\m -> - liftIO $ G.gegl_node_set (actorNodes M.! fst m) $ G.Operation "" $ - (G.Property (snd m) apValue) : [] - ) apMapping - ) actorProperties - -getProperty :: (Show a, Ord a) => String -> Actor a -> Maybe G.PropertyValue -getProperty name act = - case find (\a -> name == apName a) $ actorProperties act of - Just p -> Just $ apValue p - Nothing -> Nothing diff --git a/src/Affection/Animation.hs b/src/Affection/Animation.hs deleted file mode 100644 index 87d2e8a..0000000 --- a/src/Affection/Animation.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - -module Affection.Animation - ( SpriteAnimation(..) - , runAnimation - ) where - -import Affection.Actor -import Affection.Types -import Affection.Property - -import qualified GEGL as G - -import Control.Monad.State - -data SpriteAnimation = SpriteAnimation - { sanimCurrentFrame :: Int - , sanimSprites :: [FilePath] - , sanimFrameDuration :: Double - , sanimLoop :: Bool - , sanimLastChange :: Double - , sanimPropName :: String - } - -runAnimation - :: (Show a, Ord a) - => Actor a - -> SpriteAnimation - -> Affection us (SpriteAnimation, Actor a) -runAnimation act anim@SpriteAnimation{..} = do - ad <- get - let elapsed = elapsedTime ad - if elapsed - sanimLastChange > sanimFrameDuration - then do - let nframe = - if sanimCurrentFrame + 1 > length sanimSprites - then - if sanimLoop then 1 else sanimCurrentFrame - else sanimCurrentFrame + 1 - nact = - updateProperties - (props $ prop sanimPropName $ sanimSprites !! (nframe - 1)) - act - return (anim - { sanimCurrentFrame = nframe - , sanimLastChange = elapsed - }, nact) - else - return (anim, act) diff --git a/src/Affection/Draw.hs b/src/Affection/Draw.hs deleted file mode 100644 index e533f7e..0000000 --- a/src/Affection/Draw.hs +++ /dev/null @@ -1,240 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - --- | Module for drawing primitives -module Affection.Draw - ( drawRect - , clear - , handleDrawRequest - , invalidateDrawRequest - , process - , present - , render - , clearArea - ) where - -import Affection.Types - -import Data.Maybe (maybe) -import Data.ByteString (ByteString) - -import Foreign -import Foreign.C.Types -import Foreign.Marshal.Alloc (malloc, free) - -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 - } - --- | Process a node graph -process - :: G.GeglNode - -> Affection us () -process = liftIO . G.gegl_node_process - --- | Update of a specific region on the texture -present - :: G.GeglRectangle -- ^ Area to be updated - -> G.GeglBuffer -- ^ Target buffer - -> Bool -- ^ Shall the 'DrawRequest' persist? - -> Affection us () -present rect buf kill = do - ad <- get - let k = if not kill then Kill Nothing else Persist - put ad - { drawStack = DrawRequest rect buf k : drawStack ad - } - --- | Render the Texture or a clipping thereof. The clipping will be stretched --- to fit the render target. -render - :: Maybe G.GeglRectangle - -- ^ Area of the texture to render. - -- Pass 'Nothing' to render the whole texture. - -> Maybe G.GeglRectangle - -- ^ Area of render target to draw to. - -- Pass 'Nothing' to render to the whole render target. - -> Affection us () -render msrc mtgt = - do - AffectionData{..} <- get - SDL.copy - windowRenderer - drawTexture - src - tgt - where - toSdlRect (G.GeglRectangle x y w h) = SDL.Rectangle - (SDL.P $ SDL.V2 (CInt $ fromIntegral x) (CInt $ fromIntegral y)) - (SDL.V2 (CInt $ fromIntegral w) (CInt $ fromIntegral h)) - src = maybe Nothing (Just . toSdlRect) msrc - tgt = maybe Nothing (Just . toSdlRect) mtgt - -putToTexture - :: G.GeglRectangle - -> Int - -> Int - -> DrawRequest - -> Affection us () -putToTexture realRect stride cpp DrawRequest{..} = do - ad <- get - destRect <- return $ - SDL.Rectangle - (SDL.P $ SDL.V2 - (CInt $ fromIntegral $ rectangleX realRect) - (CInt $ fromIntegral $ rectangleY realRect) - ) - (SDL.V2 - (CInt $ fromIntegral $ rectangleWidth realRect) - (CInt $ fromIntegral $ rectangleHeight realRect) - ) - (destPtr, destStride) <- SDL.lockTexture - (drawTexture ad) - (Just destRect) - liftIO $ G.gegl_buffer_get - requestBuffer - (Just realRect) - 1 - (Just $ drawFormat ad) - destPtr - stride - G.GeglAbyssNone - SDL.unlockTexture $ drawTexture 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 stride cpp dr@DrawRequest{..} = do - ad <- get - -- let surf = drawSurface ad - mrealRect <- liftIO $ G.gegl_rectangle_intersect - requestArea - (uncurry (G.GeglRectangle 0 0) (drawDimensions ad)) - maybe (return()) (\realRect -> - -- putToSurface pixels realRect stride cpp dr - putToTexture realRect stride cpp dr - ) mrealRect - case requestPersist of - Persist -> - return Nothing - Kill _ -> - return $ Just dr - --- | clear a previously drawn area -invalidateDrawRequest - -- :: Ptr a -- ^ Pixel buffer to blit to - -- -> B.BablFormatPtr -- ^ format to blit in - :: Int -- ^ Stride - -> Int -- ^ Components per Pixel - -> DrawRequest -- ^ Drawrequest to invalidate - -> Affection us () -invalidateDrawRequest stride cpp dr@DrawRequest{..} = do - ad <- get - mrealRect <- liftIO $ G.gegl_rectangle_intersect - requestArea - (uncurry (G.GeglRectangle 0 0) (drawDimensions ad)) - maybe (return()) (\realRect -> do - liftIO $ clearArea requestBuffer realRect - -- putToSurface pixels realRect stride cpp dr - putToTexture realRect stride cpp dr - ) mrealRect - case requestPersist of - Kill (Just victim) -> - liftIO $ G.gegl_node_drop victim - _ -> - return () - -- liftIO $ SDL.updateWindowSurface $ drawWindow ad - --- | compute color for a single pixel -colorize - :: (G.ComponentValue, G.ComponentValue, G.ComponentValue, G.ComponentValue) -- ^ Pixel information in buffer - -> G.Color -- ^ Color to draw over - -> (G.ComponentValue, G.ComponentValue, G.ComponentValue, G.ComponentValue) -- ^ Resulting colour -colorize (rr, rg, rb, ra) col = - let (G.CVdouble (CDouble br)) = rr - (G.CVdouble (CDouble bg)) = rg - (G.CVdouble (CDouble bb)) = rb - (G.CVdouble (CDouble ba)) = ra - (cr, cg, cb) = case col of - G.RGBA r g b _ -> (r, g, b) - G.RGB r g b -> (r, g, b) - ca = case col of - G.RGBA _ _ _ a -> a - G.RGB{} -> 1 - alpha = ca - dst_a = ba - da = alpha + dst_a * (1 - alpha) - a_term = dst_a * (1 - alpha) - red = cr * alpha + br * a_term - gre = cg * alpha + bg * a_term - blu = cb * alpha + bb * a_term - in - ( G.CVdouble $ CDouble $ red / da - , G.CVdouble $ CDouble $ gre / da - , G.CVdouble $ CDouble $ blu / da - , G.CVdouble $ CDouble ca - ) - -unsafeColorize col = - let - (r, g, b) = case col of - G.RGBA cr cg cb _ -> (cr, cg, cb) - G.RGB cr cg cb -> (cr, cg, cb) - a = case col of - G.RGBA _ _ _ ca -> ca - G.RGB{} -> 1 - in - ( G.CVdouble $ CDouble r - , G.CVdouble $ CDouble g - , G.CVdouble $ CDouble b - , G.CVdouble $ CDouble a - ) - --- | Clear a specified area of a buffer from all data -clearArea - :: G.GeglBuffer -- ^ Target buffer - -> G.GeglRectangle -- ^ Area to clear - -> IO () -clearArea = G.gegl_buffer_clear - --- | Clear the whole drawing area -clear :: G.GeglBuffer -> Affection us () -clear buffer = do - ad <- get - let (w, h) = drawDimensions ad - liftIO $ clearArea buffer (GeglRectangle 0 0 w h) diff --git a/src/Affection/Particle.hs b/src/Affection/Particle.hs deleted file mode 100644 index 637709f..0000000 --- a/src/Affection/Particle.hs +++ /dev/null @@ -1,163 +0,0 @@ -{-# LANGUAGE BangPatterns #-} - --- | This module introduces a simple particle system to Affection -module Affection.Particle - ( updateParticle - , drawParticles - , updateParticleSystem - , drawParticleSystem - , insertParticle - ) where - -import Affection.Types - -import Control.Monad -import Control.Monad.State (get) - -import Data.Maybe - -import qualified GEGL as G - -import Debug.Trace - --- This function updates particles through a specified function. Particle ageing --- and death is being handled by 'updateParticles' itself and does not need to --- bother you. -updateParticle - :: Double - -- ^ Elapsed time in seconds - -> (Double -> Particle -> Affection us Particle) - -- ^ Update function for each 'Particle' - -> [Particle] - -- ^ List of 'Particle's to be processed - -> Affection us [Particle] - -- ^ processed 'Particle's -updateParticle time func l = - catMaybes <$> mapM (\p -> do - now <- elapsedTime <$> get - if particleCreation p + particleTimeToLive p < now - then do - dropParticle p - return Nothing - else do - np <- func time p - return $ Just np - ) l - -- updateParticle' time func l - where - updateParticle' _ _ [] = return [] - updateParticle' dt fun [p] = do - now <- elapsedTime <$> get - if particleCreation p + particleTimeToLive p < now - then do - dropParticle p - return [] - else - (: []) <$> func time p - updateParticle' dt fun (p:ps) = do - now <- elapsedTime <$> get - if particleCreation p + particleTimeToLive p < now - then do - dropParticle p - updateParticle' dt fun ps - else do - np <- fun dt p - (np :) <$> updateParticle' dt fun ps - dropParticle p = do - mproducer <- liftIO $ G.gegl_node_get_producer - (particleStackCont p) - "input" - maybe (return ()) (\(producer, padname) -> do - consumers <- liftIO $ G.gegl_node_get_consumers - (particleStackCont p) - "output" - liftIO $ mapM_ (uncurry $ G.gegl_node_connect_to - producer - padname - ) consumers - ) mproducer - liftIO $ G.gegl_node_drop $ particleRootNode p - --- | Get the next living particle from a list -nextLiving - :: [Maybe Particle] - -> Maybe Particle -nextLiving [] = Nothing -nextLiving acc = case catMaybes acc of - [] -> Nothing - ps -> Just $ head ps - -drawParticles - :: (Particle -> Affection us ()) - -> [Particle] - -> Affection us () -drawParticles = mapM_ - -updateParticleSystem - :: ParticleSystem - -> Double - -> (Double -> Particle -> Affection us Particle) - -> Affection us ParticleSystem -updateParticleSystem sys sec upd = do - !x <- updateParticle sec upd (partStorList $ partSysParts sys) - if not $ null x - then do - return sys - { partSysParts = (partSysParts sys) - { partStorList = x - } - } - else do - return sys - { partSysParts = ParticleStorage - { partStorList = [] - , partStorLatest = Nothing - } - } - -drawParticleSystem - :: ParticleSystem - -> (G.GeglBuffer -> G.GeglNode -> Particle -> Affection us ()) - -> Affection us () -drawParticleSystem sys draw = - if not (null parts) - then do - liftIO $ G.gegl_node_link (particleStackCont $ head parts) (partSysNode sys) - mapM_ (draw (partSysBuffer sys) (partSysNode sys)) parts - else do - _ <- liftIO $ G.gegl_node_disconnect (partSysNode sys) "input" - return () - where - parts = partStorList (partSysParts sys) - --- | Function for inserting a new 'Particle' into its 'PartileSystem' -insertParticle - :: ParticleSystem -- ^ 'ParticleSystem' to insert into - -> Particle -- ^ 'Particle' to insert - -> Affection us ParticleSystem -- ^ resulting new 'ParticleSystem' -insertParticle ps p = do - now <- elapsedTime <$> get - let newList = chronoInsert now (partStorList $ partSysParts ps) p - liftIO $ G.gegl_node_link_many (reverse $ map particleStackCont newList) - return ps - { partSysParts = (partSysParts ps) - { partStorLatest = Just p - , partStorList = newList - } - } - --- | Insert a 'Particle' into its chronologically ordered list -chronoInsert - :: Double -- ^ Time in seconds from beginning of program execution - -> [Particle] -- ^ List to insert to - -> Particle -- ^ 'Particle' to insert - -> [Particle] -- ^ Resulting list -chronoInsert now [] np = [np] -chronoInsert now [p] np = - if now + particleTimeToLive p < (particleCreation np + particleTimeToLive np) - then p : [np] - else np : [p] -chronoInsert now l@(p:ps) np = - if now + particleTimeToLive p < (particleCreation np + particleTimeToLive np) - then p : chronoInsert now ps np - else np : l diff --git a/src/Affection/Property.hs b/src/Affection/Property.hs deleted file mode 100644 index 78e209f..0000000 --- a/src/Affection/Property.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -module Affection.Property - ( Props - , prop - , props - ) where - -import qualified GEGL as G -import qualified BABL as B - -import Control.Monad.State.Lazy -import Foreign.Ptr (Ptr) - -type Props a = State [G.Property] a - -props :: Props a -> [G.Property] -props = flip execState [] - -prop :: IsPropertyValue v => String -> v -> Props () -prop k v = do - ps <- get - put $ G.Property k (toPropertyValue v) : ps - -class IsPropertyValue v where - toPropertyValue :: v -> G.PropertyValue - -instance IsPropertyValue Int where - toPropertyValue = G.PropertyInt - -instance IsPropertyValue String where - toPropertyValue = G.PropertyString - -instance IsPropertyValue Double where - toPropertyValue = G.PropertyDouble - -instance IsPropertyValue G.Color where - toPropertyValue = G.PropertyColor - -instance IsPropertyValue B.PixelFormat where - toPropertyValue = G.PropertyFormat -instance IsPropertyValue G.GeglBuffer where - toPropertyValue = G.PropertyBuffer - -instance IsPropertyValue (Ptr ()) where - toPropertyValue = G.PropertyPointer