blerg
This commit is contained in:
nek0
parent
1875797cb1
commit
63a493ed19
10 changed files with 460 additions and 90 deletions
|
|
@ -43,6 +43,7 @@ library
|
|||
, Affection.MouseInteractable
|
||||
, Affection.Property
|
||||
, Affection.Actor
|
||||
, Affection.Animation
|
||||
default-extensions: OverloadedStrings
|
||||
|
||||
-- Modules included in this library but not exported.
|
||||
|
|
@ -191,6 +192,7 @@ executable example05
|
|||
, gegl
|
||||
, babl
|
||||
, containers
|
||||
, unordered-containers
|
||||
, mtl
|
||||
, random
|
||||
, matrix
|
||||
|
|
|
|||
294
examples/example05.1.hs
Normal file
294
examples/example05.1.hs
Normal file
|
|
@ -0,0 +1,294 @@
|
|||
{-# LANGUAGE RecordWildCards, BangPatterns #-}
|
||||
|
||||
import Affection
|
||||
import qualified SDL
|
||||
import qualified GEGL as G
|
||||
import qualified BABL as B
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified Data.Matrix as X
|
||||
import Data.List as L
|
||||
import Data.Maybe (fromJust, catMaybes)
|
||||
-- import Data.Vector as V
|
||||
import System.Random (randomRIO)
|
||||
import Control.Monad as CM (when, unless, foldM)
|
||||
import qualified Control.Monad.Parallel as MP
|
||||
import Control.Parallel.Strategies
|
||||
import Foreign.C.Types
|
||||
import Foreign.Marshal.Utils
|
||||
|
||||
import Debug.Trace
|
||||
|
||||
dimension :: Int
|
||||
dimension = 60
|
||||
|
||||
resolution :: Int
|
||||
resolution = 600
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
conf <- return AffectionConfig
|
||||
{ initComponents = All
|
||||
, windowTitle = "Affection: example00"
|
||||
, windowConfig = SDL.defaultWindow
|
||||
{ windowInitialSize = SDL.V2
|
||||
(CInt $ fromIntegral resolution)
|
||||
(CInt $ fromIntegral resolution)
|
||||
}
|
||||
, canvasSize = Nothing
|
||||
, preLoop = loadList
|
||||
, eventLoop = handle
|
||||
, updateLoop = Main.update
|
||||
, drawLoop = draw
|
||||
, loadState = load
|
||||
, cleanUp = clean
|
||||
}
|
||||
withAffection conf
|
||||
|
||||
data UserData = UserData
|
||||
{ nodeGraph :: M.Map String G.GeglNode
|
||||
, foreground :: G.GeglBuffer
|
||||
, keysDown :: [SDL.Keycode]
|
||||
, liveIndices :: [(Int, Int)]
|
||||
, indices :: [(Int, Int)]
|
||||
-- , cells :: [((Int, Int), Actor String)]
|
||||
-- , updateActors :: [Actor String]
|
||||
}
|
||||
|
||||
load :: IO UserData
|
||||
load = do
|
||||
traceM "loading"
|
||||
root <- G.gegl_node_new
|
||||
traceM "new root node"
|
||||
let bgProps = props $ do
|
||||
prop "x" (0 :: Double)
|
||||
prop "y" (0 :: Double)
|
||||
prop "width" (fromIntegral resolution :: Double)
|
||||
prop "height" (fromIntegral resolution :: Double)
|
||||
prop "color" $ G.RGB 0 0 0
|
||||
bg <- G.gegl_node_new_child root $ G.Operation "gegl:rectangle" bgProps
|
||||
traceM "background"
|
||||
over <- G.gegl_node_new_child root G.defaultOverOperation
|
||||
traceM "over"
|
||||
buffer <- G.gegl_buffer_new (Just $ G.GeglRectangle 0 0 resolution resolution) =<<
|
||||
B.babl_format (B.PixelFormat B.RGBA B.CFfloat)
|
||||
sink <- G.gegl_node_new_child root $ G.Operation "gegl:copy-buffer" $
|
||||
props $
|
||||
prop "buffer" buffer
|
||||
traceM "buffer-sink"
|
||||
crop <- G.gegl_node_new_child root $ G.Operation "gegl:crop" $
|
||||
props $ do
|
||||
prop "width" (fromIntegral resolution :: Double)
|
||||
prop "height" (fromIntegral resolution :: Double)
|
||||
G.gegl_node_link_many [bg, over, crop, sink]
|
||||
nop <- G.gegl_node_new_child root $ G.Operation "gegl:nop" []
|
||||
_ <- G.gegl_node_connect_to nop "output" over "aux"
|
||||
traceM "connections made"
|
||||
myMap <- return $ M.fromList
|
||||
[ ("root" , root)
|
||||
, ("over" , over)
|
||||
, ("background" , bg)
|
||||
, ("sink" , sink)
|
||||
, ("nop" , nop)
|
||||
, ("crop" , crop)
|
||||
]
|
||||
traceM "building matrix"
|
||||
let !emptyMatrix = X.matrix dimension dimension (const False)
|
||||
!indices = [(row, col) | row <- [1..dimension], col <- [1..dimension]]
|
||||
-- traceM "building cells"
|
||||
-- cells <- foldM (\acc index@(row, col) -> do
|
||||
-- tempOver <- G.gegl_node_new_child root $ G.defaultOverOperation
|
||||
-- let !scale = (fromIntegral resolution) / (fromIntegral dimension)
|
||||
-- tempProps =
|
||||
-- props $ do
|
||||
-- prop "x" (((fromIntegral col) - 1) * scale :: Double)
|
||||
-- prop "y" (((fromIntegral row) - 1) * scale :: Double)
|
||||
-- prop "width" (scale :: Double)
|
||||
-- prop "height" (scale :: Double)
|
||||
-- prop "color" $ G.RGB 1 1 1
|
||||
-- tempRect <- G.gegl_node_new_child root $ G.Operation "gegl:rectangle"
|
||||
-- tempProps
|
||||
-- G.gegl_node_connect_to tempRect "output" tempOver "aux"
|
||||
-- let tempMap = M.fromList
|
||||
-- [ ("over", tempOver)
|
||||
-- , ("rect", tempRect)
|
||||
-- ]
|
||||
-- tempAProps =
|
||||
-- map (\p -> ActorProperty
|
||||
-- { apName = G.propertyName p
|
||||
-- , apValue = G.propertyValue p
|
||||
-- , apMapping = Just "rect"
|
||||
-- }) tempProps
|
||||
-- traceIO $ show index
|
||||
-- return $ (index, Actor
|
||||
-- { actorProperties = tempAProps
|
||||
-- , actorNodes = tempMap
|
||||
-- }) : acc
|
||||
-- )
|
||||
-- ([] :: [((Int, Int), Actor String)])
|
||||
-- indices
|
||||
-- :: IO [((Int, Int), Actor String)]
|
||||
traceM "loading complete"
|
||||
return UserData
|
||||
{ nodeGraph = myMap
|
||||
, foreground = buffer
|
||||
, keysDown = []
|
||||
, indices = indices
|
||||
, liveIndices = []
|
||||
-- , cells = cells
|
||||
-- , updateActors = []
|
||||
}
|
||||
|
||||
loadList :: Affection UserData ()
|
||||
loadList = do
|
||||
ud@UserData{..} <- getAffection
|
||||
init <- foldM (\acc coord -> do
|
||||
trig <- liftIO $ randomRIO (True, False)
|
||||
if trig then return (coord : acc) else return acc
|
||||
) [] indices
|
||||
putAffection ud
|
||||
{ liveIndices = init
|
||||
}
|
||||
|
||||
getNeighbors :: (Int, Int) -> Affection UserData [(Int, Int)]
|
||||
getNeighbors (row, col) =
|
||||
do
|
||||
UserData{..} <- getAffection
|
||||
mapM (\(pr, pc) ->
|
||||
return (overflow(row + pr), overflow(col + pc))
|
||||
) lcs
|
||||
where
|
||||
overflow x
|
||||
| x < 1 = dimension
|
||||
| x > dimension = 1
|
||||
| otherwise = x
|
||||
|
||||
lcs :: [(Int, Int)]
|
||||
lcs =
|
||||
[ (-1, -1)
|
||||
, (-1, 0)
|
||||
, (-1, 1)
|
||||
, (0, -1)
|
||||
-- , (0, 0)
|
||||
, (0, 1)
|
||||
, (1, -1)
|
||||
, (1, 0)
|
||||
, (1, 1)
|
||||
]
|
||||
|
||||
draw :: Affection UserData ()
|
||||
draw = do
|
||||
traceM "drawing"
|
||||
ad <- get
|
||||
ud@UserData{..} <- getAffection
|
||||
SDL.rendererDrawColor (windowRenderer ad) SDL.$= (SDL.V4 0 0 0 255)
|
||||
SDL.clear (windowRenderer ad)
|
||||
SDL.rendererDrawColor (windowRenderer ad) SDL.$= (SDL.V4 255 255 255 255)
|
||||
MP.mapM_ (\(row, col) ->
|
||||
let scale = floor (fromIntegral resolution / fromIntegral dimension)
|
||||
in
|
||||
SDL.fillRect
|
||||
(windowRenderer ad)
|
||||
(Just ( SDL.Rectangle
|
||||
(SDL.P (SDL.V2
|
||||
(CInt $ fromIntegral $ (col - 1) * scale)
|
||||
(CInt $ fromIntegral $ (row - 1) * scale)
|
||||
))
|
||||
(SDL.V2
|
||||
(CInt $ fromIntegral $ scale)
|
||||
(CInt $ fromIntegral $ scale)
|
||||
)
|
||||
))
|
||||
) liveIndices
|
||||
-- render Nothing Nothing
|
||||
-- let livingActors = catMaybes $ parMap rpar (\i -> lookup i cells) liveIndices
|
||||
-- unless (null livingActors) $ do
|
||||
-- liftIO $ G.gegl_node_link_many $
|
||||
-- parMap rpar (\a -> (actorNodes a) M.! "over") livingActors
|
||||
-- _ <- liftIO $ G.gegl_node_link ((actorNodes $ last livingActors) M.! "over")
|
||||
-- (nodeGraph M.! "nop")
|
||||
-- return ()
|
||||
-- process (nodeGraph M.! "sink")
|
||||
-- present (G.GeglRectangle 0 0 resolution resolution) foreground True
|
||||
-- render
|
||||
-- Nothing
|
||||
-- Nothing
|
||||
-- _ <- liftIO $ MP.mapM
|
||||
-- (\a -> G.gegl_node_disconnect (actorNodes a M.! "over") "input"
|
||||
-- ) livingActors
|
||||
-- putAffection ud
|
||||
-- { updateActors = []
|
||||
-- }
|
||||
|
||||
update :: Double -> Affection UserData ()
|
||||
update dt = do
|
||||
traceM "updating"
|
||||
|
||||
ud <- getAffection
|
||||
elapsed <- getElapsedTime
|
||||
|
||||
traceM $ show (1 / dt) ++ " FPS"
|
||||
traceM $ show $ keysDown ud
|
||||
|
||||
relevant <- getRelevant (liveIndices ud)
|
||||
|
||||
new <- catMaybes <$> MP.mapM (\coord@(row, col) -> do
|
||||
neighs <-
|
||||
foldl (\acc n -> if n `elem` liveIndices ud then acc + 1 else acc) 0 <$>
|
||||
getNeighbors coord
|
||||
let ret
|
||||
| coord `elem` liveIndices ud && (neighs == 2 || neighs == 3) =
|
||||
Just coord
|
||||
| neighs == 3 =
|
||||
Just coord
|
||||
| otherwise =
|
||||
Nothing
|
||||
return ret
|
||||
) relevant
|
||||
|
||||
ud2 <- getAffection
|
||||
putAffection ud2
|
||||
{ liveIndices = new
|
||||
}
|
||||
|
||||
mapM_ (\code ->
|
||||
when (code == SDL.KeycodeR) loadList
|
||||
) (keysDown ud)
|
||||
|
||||
getRelevant :: [(Int, Int)] -> Affection UserData [(Int, Int)]
|
||||
getRelevant ls =
|
||||
getRelevant' ls
|
||||
where
|
||||
getRelevant' xs = foldM (\acc x -> do
|
||||
neighs <- getNeighbors x
|
||||
let slice = (x : neighs)
|
||||
rels = foldl (\a y ->
|
||||
if y `elem` acc then a else y : a
|
||||
) [] slice
|
||||
return (acc ++ rels)
|
||||
) [] xs
|
||||
|
||||
handle :: SDL.EventPayload -> Affection UserData ()
|
||||
handle (SDL.KeyboardEvent dat) =
|
||||
when (not (SDL.keyboardEventRepeat dat)) $ do
|
||||
ud <- getAffection
|
||||
if (SDL.keyboardEventKeyMotion dat == SDL.Pressed)
|
||||
then
|
||||
putAffection ud
|
||||
{ keysDown =
|
||||
SDL.keysymKeycode (SDL.keyboardEventKeysym dat) : keysDown ud
|
||||
}
|
||||
else
|
||||
putAffection ud
|
||||
{ keysDown =
|
||||
delete (SDL.keysymKeycode $ SDL.keyboardEventKeysym dat) (keysDown ud)
|
||||
}
|
||||
|
||||
handle (SDL.WindowClosedEvent _) = do
|
||||
traceM "seeya!"
|
||||
quit
|
||||
|
||||
handle _ =
|
||||
return ()
|
||||
|
||||
clean :: UserData -> IO ()
|
||||
clean _ = return ()
|
||||
|
|
@ -5,12 +5,15 @@ import qualified SDL
|
|||
import qualified GEGL as G
|
||||
import qualified BABL as B
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Data.HashSet as HS
|
||||
import qualified Data.Matrix as X
|
||||
import Data.List as L
|
||||
import Data.Foldable (foldrM, foldlM)
|
||||
import Data.Maybe (fromJust, catMaybes)
|
||||
-- import Data.Vector as V
|
||||
import System.Random (randomRIO)
|
||||
import Control.Monad as CM (when, unless, foldM)
|
||||
import Control.Monad as CM (when, unless)
|
||||
import qualified Control.Monad.Parallel as MP
|
||||
import Control.Parallel.Strategies
|
||||
import Foreign.C.Types
|
||||
|
|
@ -48,9 +51,9 @@ data UserData = UserData
|
|||
{ nodeGraph :: M.Map String G.GeglNode
|
||||
, foreground :: G.GeglBuffer
|
||||
, keysDown :: [SDL.Keycode]
|
||||
, liveIndices :: [(Int, Int)]
|
||||
, liveIndices :: HS.HashSet (Int, Int)
|
||||
, indices :: [(Int, Int)]
|
||||
, cells :: [((Int, Int), Actor String)]
|
||||
, cells :: HM.HashMap (Int, Int) (Actor String)
|
||||
, updateActors :: [Actor String]
|
||||
}
|
||||
|
||||
|
|
@ -95,7 +98,7 @@ load = do
|
|||
let !emptyMatrix = X.matrix dimension dimension (const False)
|
||||
!indices = [(row, col) | row <- [1..dimension], col <- [1..dimension]]
|
||||
traceM "building cells"
|
||||
cells <- foldM (\acc index@(row, col) -> do
|
||||
cells <- foldrM (\index@(row, col) acc -> do
|
||||
tempOver <- G.gegl_node_new_child root $ G.defaultOverOperation
|
||||
let !scale = (fromIntegral resolution) / (fromIntegral dimension)
|
||||
tempProps =
|
||||
|
|
@ -119,21 +122,21 @@ load = do
|
|||
, apMapping = Just "rect"
|
||||
}) tempProps
|
||||
traceIO $ show index
|
||||
return $ (index, Actor
|
||||
return $ HM.insert index Actor
|
||||
{ actorProperties = tempAProps
|
||||
, actorNodes = tempMap
|
||||
}) : acc
|
||||
}
|
||||
acc
|
||||
)
|
||||
([] :: [((Int, Int), Actor String)])
|
||||
HM.empty
|
||||
indices
|
||||
:: IO [((Int, Int), Actor String)]
|
||||
traceM "loading complete"
|
||||
return UserData
|
||||
{ nodeGraph = myMap
|
||||
, foreground = buffer
|
||||
, keysDown = []
|
||||
, indices = indices
|
||||
, liveIndices = []
|
||||
, liveIndices = HS.empty
|
||||
, cells = cells
|
||||
, updateActors = []
|
||||
}
|
||||
|
|
@ -141,21 +144,18 @@ load = do
|
|||
loadList :: Affection UserData ()
|
||||
loadList = do
|
||||
ud@UserData{..} <- getAffection
|
||||
init <- foldM (\acc coord -> do
|
||||
-- init <- foldrM (\coord acc -> do
|
||||
init <- foldlM (\acc coord -> do
|
||||
trig <- liftIO $ randomRIO (True, False)
|
||||
if trig then return (coord : acc) else return acc
|
||||
) [] indices
|
||||
if trig then return (HS.insert coord acc) else return acc
|
||||
) HS.empty indices
|
||||
putAffection ud
|
||||
{ liveIndices = init
|
||||
}
|
||||
|
||||
getNeighbors :: (Int, Int) -> Affection UserData [(Int, Int)]
|
||||
getNeighbors :: (Int, Int) -> [(Int, Int)]
|
||||
getNeighbors (row, col) =
|
||||
do
|
||||
UserData{..} <- getAffection
|
||||
mapM (\(pr, pc) ->
|
||||
return (overflow(row + pr), overflow(col + pc))
|
||||
) lcs
|
||||
map (\(pr, pc) -> (overflow(row + pr), overflow(col + pc))) lcs
|
||||
where
|
||||
overflow x
|
||||
| x < 1 = dimension
|
||||
|
|
@ -179,7 +179,7 @@ draw :: Affection UserData ()
|
|||
draw = do
|
||||
traceM "drawing"
|
||||
ud@UserData{..} <- getAffection
|
||||
let livingActors = catMaybes $ parMap rpar (\i -> lookup i cells) liveIndices
|
||||
let livingActors = parMap rpar (cells HM.!) $ HS.toList liveIndices
|
||||
unless (null livingActors) $ do
|
||||
liftIO $ G.gegl_node_link_many $
|
||||
parMap rpar (\a -> (actorNodes a) M.! "over") livingActors
|
||||
|
|
@ -191,9 +191,9 @@ draw = do
|
|||
render
|
||||
Nothing
|
||||
Nothing
|
||||
_ <- liftIO $ MP.mapM
|
||||
(\a -> G.gegl_node_disconnect (actorNodes a M.! "over") "input"
|
||||
) livingActors
|
||||
-- _ <- liftIO $ MP.mapM
|
||||
-- (\a -> G.gegl_node_disconnect (actorNodes a M.! "over") "input"
|
||||
-- ) livingActors
|
||||
putAffection ud
|
||||
{ updateActors = []
|
||||
}
|
||||
|
|
@ -210,19 +210,48 @@ update dt = do
|
|||
|
||||
relevant <- getRelevant (liveIndices ud)
|
||||
|
||||
new <- catMaybes <$> MP.mapM (\coord@(row, col) -> do
|
||||
neighs <-
|
||||
foldl (\acc n -> if n `elem` liveIndices ud then acc + 1 else acc) 0 <$>
|
||||
getNeighbors coord
|
||||
let ret
|
||||
-- let new = HS.fromList $ catMaybes $ parMap rpar (\coord@(row, col) ->
|
||||
-- let neighs =
|
||||
-- foldl (\acc n -> if n `elem` liveIndices ud then acc + 1 else acc) 0 $
|
||||
-- getNeighbors coord
|
||||
-- ret
|
||||
-- | coord `elem` liveIndices ud && (neighs == 2 || neighs == 3) =
|
||||
-- Just coord
|
||||
-- | neighs == 3 =
|
||||
-- Just coord
|
||||
-- | otherwise =
|
||||
-- Nothing
|
||||
-- in ret
|
||||
-- ) (HS.toList relevant)
|
||||
|
||||
new <- foldrM (\coord@(row, col) acc -> do
|
||||
-- new <- foldlM (\acc coord@(row, col) -> do
|
||||
let !neighs = sum $
|
||||
map (\n -> if n `elem` liveIndices ud then 1 else 0)$
|
||||
getNeighbors coord
|
||||
ret
|
||||
| coord `elem` liveIndices ud && (neighs == 2 || neighs == 3) =
|
||||
Just coord
|
||||
HS.insert coord acc
|
||||
| neighs == 3 =
|
||||
Just coord
|
||||
HS.insert coord acc
|
||||
| otherwise =
|
||||
Nothing
|
||||
acc
|
||||
return ret
|
||||
) relevant
|
||||
) HS.empty relevant
|
||||
|
||||
-- new <- catMaybes <$> MP.mapM (\coord@(row, col) -> do
|
||||
-- neighs <-
|
||||
-- foldl (\acc n -> if n `elem` liveIndices ud then acc + 1 else acc) 0 <$>
|
||||
-- getNeighbors coord
|
||||
-- let ret
|
||||
-- | coord `elem` liveIndices ud && (neighs == 2 || neighs == 3) =
|
||||
-- Just coord
|
||||
-- | neighs == 3 =
|
||||
-- Just coord
|
||||
-- | otherwise =
|
||||
-- Nothing
|
||||
-- return ret
|
||||
-- ) relevant
|
||||
|
||||
ud2 <- getAffection
|
||||
putAffection ud2
|
||||
|
|
@ -233,18 +262,19 @@ update dt = do
|
|||
when (code == SDL.KeycodeR) loadList
|
||||
) (keysDown ud)
|
||||
|
||||
getRelevant :: [(Int, Int)] -> Affection UserData [(Int, Int)]
|
||||
getRelevant ls =
|
||||
getRelevant :: HS.HashSet (Int, Int) -> Affection UserData (HS.HashSet (Int, Int))
|
||||
getRelevant ls = do
|
||||
getRelevant' ls
|
||||
where
|
||||
getRelevant' xs = foldM (\acc x -> do
|
||||
neighs <- getNeighbors x
|
||||
let slice = (x : neighs)
|
||||
rels = foldl (\a y ->
|
||||
if y `elem` acc then a else y : a
|
||||
) [] slice
|
||||
return (acc ++ rels)
|
||||
) [] xs
|
||||
getRelevant' xs = foldlM (\acc x ->
|
||||
let neighs = getNeighbors x
|
||||
slice = (x : neighs)
|
||||
rels = foldr (\y a ->
|
||||
-- rels = foldl (\a y ->
|
||||
if y `elem` acc then a else HS.insert y a
|
||||
) HS.empty slice
|
||||
in return (acc `HS.union` rels)
|
||||
) HS.empty xs
|
||||
|
||||
handle :: SDL.EventPayload -> Affection UserData ()
|
||||
handle (SDL.KeyboardEvent dat) =
|
||||
|
|
@ -271,3 +301,12 @@ handle _ =
|
|||
|
||||
clean :: UserData -> IO ()
|
||||
clean _ = return ()
|
||||
|
||||
parHSMap f = (`using` parTraversable rpar) . HM.map f
|
||||
|
||||
-- catHSMaybe =
|
||||
-- foldr (\x acc ->
|
||||
-- case x of
|
||||
-- Just a -> a `HS.insert` acc
|
||||
-- Nothing -> acc
|
||||
-- ) HS.empty
|
||||
|
|
|
|||
|
|
@ -41,6 +41,7 @@ import Affection.StateMachine as A
|
|||
import Affection.MouseInteractable as A
|
||||
import Affection.Property as A
|
||||
import Affection.Actor as A
|
||||
import Affection.Animation as A
|
||||
|
||||
import qualified BABL as B
|
||||
|
||||
|
|
|
|||
|
|
@ -3,11 +3,12 @@
|
|||
-- | This module implements the Actor, a Datastructure binding a 'G.GeglNode'
|
||||
-- to a game asset
|
||||
module Affection.Actor
|
||||
( Actor(..)
|
||||
, ActorProperty(..)
|
||||
, updateProperties
|
||||
, applyProperties
|
||||
) where
|
||||
( Actor(..)
|
||||
, ActorProperty(..)
|
||||
, updateProperties
|
||||
, applyProperties
|
||||
, getProperty
|
||||
) where
|
||||
|
||||
import qualified GEGL as G
|
||||
|
||||
|
|
@ -20,13 +21,14 @@ import Affection.Types
|
|||
data Ord a => Actor a = Actor
|
||||
{ actorProperties :: [ActorProperty a]
|
||||
, actorNodes :: M.Map a G.GeglNode
|
||||
}
|
||||
, actorFlange :: G.GeglNode
|
||||
} deriving (Eq)
|
||||
|
||||
data Ord a => ActorProperty a = ActorProperty
|
||||
{ apName :: String
|
||||
, apValue :: G.PropertyValue
|
||||
, apMapping :: Maybe a
|
||||
}
|
||||
, apMapping :: Maybe (a, String)
|
||||
} deriving (Eq)
|
||||
|
||||
updateProperties :: Ord a => [G.Property] -> Actor a -> Actor a
|
||||
updateProperties ps act@Actor{..} =
|
||||
|
|
@ -48,7 +50,13 @@ applyProperties :: Ord a => Actor a -> Affection us ()
|
|||
applyProperties Actor{..} =
|
||||
MP.mapM_ (\(ActorProperty{..}) ->
|
||||
maybe (return ()) (\m ->
|
||||
liftIO $ G.gegl_node_set (actorNodes M.! m) $ G.Operation "" $
|
||||
(G.Property apName apValue) : []
|
||||
liftIO $ G.gegl_node_set (actorNodes M.! fst m) $ G.Operation "" $
|
||||
(G.Property (snd m) apValue) : []
|
||||
) apMapping
|
||||
) actorProperties
|
||||
|
||||
getProperty :: 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
|
||||
|
|
|
|||
49
src/Affection/Animation.hs
Normal file
49
src/Affection/Animation.hs
Normal file
|
|
@ -0,0 +1,49 @@
|
|||
{-# 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
|
||||
:: 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)
|
||||
|
|
@ -101,27 +101,6 @@ render msrc mtgt =
|
|||
src = maybe Nothing (Just . toSdlRect) msrc
|
||||
tgt = maybe Nothing (Just . toSdlRect) mtgt
|
||||
|
||||
-- putToSurface
|
||||
-- :: Ptr a
|
||||
-- -> G.GeglRectangle
|
||||
-- -> Int
|
||||
-- -> Int
|
||||
-- -> DrawRequest
|
||||
-- -> Affection us ()
|
||||
-- putToSurface pixels realRect stride cpp DrawRequest{..} = do
|
||||
-- ad <- get
|
||||
-- liftIO $ SDL.lockSurface $ drawSurface ad
|
||||
-- liftIO $ G.gegl_buffer_get
|
||||
-- requestBuffer
|
||||
-- (Just realRect)
|
||||
-- 1
|
||||
-- (Just $ drawFormat ad)
|
||||
-- (pixels `plusPtr`
|
||||
-- (rectangleX realRect * cpp + rectangleY realRect * stride))
|
||||
-- stride
|
||||
-- G.GeglAbyssNone
|
||||
-- liftIO $ SDL.unlockSurface $ drawSurface ad
|
||||
|
||||
putToTexture
|
||||
:: G.GeglRectangle
|
||||
-> Int
|
||||
|
|
@ -143,7 +122,6 @@ putToTexture realRect stride cpp DrawRequest{..} = do
|
|||
(destPtr, destStride) <- SDL.lockTexture
|
||||
(drawTexture ad)
|
||||
(Just destRect)
|
||||
-- destPtr <- liftIO $ malloc :: (Ptr ByteString)
|
||||
liftIO $ G.gegl_buffer_get
|
||||
requestBuffer
|
||||
(Just realRect)
|
||||
|
|
@ -152,17 +130,6 @@ putToTexture realRect stride cpp DrawRequest{..} = do
|
|||
destPtr
|
||||
stride
|
||||
G.GeglAbyssNone
|
||||
-- pixelData <- liftIO $ peekArray
|
||||
-- (rectangleWidth realRect * rectangleHeight realRect)
|
||||
-- destPtr
|
||||
-- SDL.updateTexture
|
||||
-- (drawTexture ad)
|
||||
-- (Just $ SDL.Rectangle
|
||||
-- (SDL.P $ SDL.V2 (rectangleX realRect) (rectangleY realRect))
|
||||
-- (SDL.V2 (rectangleWidth realRect) (rectangleHeight realRect))
|
||||
-- )
|
||||
-- pixelData
|
||||
-- (CInt $ fromIntegral stride)
|
||||
SDL.unlockTexture $ drawTexture ad
|
||||
|
||||
-- | function for handling 'DrawRequest's and updating the output
|
||||
|
|
|
|||
|
|
@ -23,11 +23,11 @@ class MouseClickable a us where
|
|||
-- This function does not consume provided events, but passes them on.
|
||||
handleMouseClicks
|
||||
:: (Foldable t, MouseClickable clickable us)
|
||||
=> SDL.Event -- ^ Piped event in
|
||||
-> t clickable -- ^ 'MouseClickable' elemt to be checked
|
||||
-> Affection us SDL.Event -- ^ Unaltered event
|
||||
=> SDL.EventPayload -- ^ Piped event in
|
||||
-> t clickable -- ^ 'MouseClickable' elemt to be checked
|
||||
-> Affection us SDL.EventPayload -- ^ Unaltered event
|
||||
handleMouseClicks e clickables =
|
||||
case SDL.eventPayload e of
|
||||
case e of
|
||||
SDL.MouseButtonEvent dat -> do
|
||||
mapM_ (\clickable -> do
|
||||
let SDL.P (SDL.V2 x y) = SDL.mouseButtonEventPos dat
|
||||
|
|
|
|||
|
|
@ -34,7 +34,17 @@ updateParticle
|
|||
-> Affection us [Particle]
|
||||
-- ^ processed 'Particle's
|
||||
updateParticle time func l =
|
||||
updateParticle' time func l
|
||||
catMaybes <$> MP.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
|
||||
|
|
|
|||
|
|
@ -9,6 +9,6 @@ import qualified SDL
|
|||
class StateMachine a us where
|
||||
smLoad :: a -> Affection us ()
|
||||
smUpdate :: a -> Double -> Affection us ()
|
||||
smEvent :: a -> Double -> SDL.Event -> Affection us ()
|
||||
smEvent :: a -> SDL.EventPayload -> Affection us ()
|
||||
smDraw :: a -> Affection us ()
|
||||
smClean :: a -> Affection us ()
|
||||
|
|
|
|||
Loading…
Reference in a new issue