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