This commit is contained in:
nek0 2017-04-17 12:40:17 +02:00
parent 1875797cb1
commit 63a493ed19
10 changed files with 460 additions and 90 deletions

View file

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

View file

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

View file

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

View file

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

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

View file

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

View file

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

View file

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

View file

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