pre-release cleanup part I

This commit is contained in:
nek0 2018-09-25 00:17:59 +02:00
parent 516134db4a
commit 8d20ab193b
5 changed files with 0 additions and 560 deletions

View file

@ -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

View file

@ -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)

View file

@ -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)

View file

@ -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

View file

@ -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