pre-release cleanup part I
This commit is contained in:
nek0
parent
516134db4a
commit
8d20ab193b
5 changed files with 0 additions and 560 deletions
|
|
@ -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
|
|
||||||
|
|
@ -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)
|
|
||||||
|
|
@ -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)
|
|
||||||
|
|
@ -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
|
|
||||||
|
|
@ -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
|
|
||||||
Loading…
Reference in a new issue