nek0/affection
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

it works only halfway

Browse source
This commit is contained in:
nek0 2017-02-17 17:15:06 +01:00
parent 93d79d16af
commit 97186c5709
8 changed files with 101 additions and 56 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

11
affection.cabal
View file

@ -6,9 +6,12 @@ name: affection
-- PVP summary: +-+------- breaking API changes
-- | | +----- non-breaking API additions
-- | | | +--- code changes with no API change
version: 0.0.0.0
version: 0.0.0.1
synopsis: A simple Game Engine using SDL
description: See homepage for description.
description: This package contains Affection, a simple game engine
written in Haskell using SDL and GEGL.
This Engine is still work in progress and even minor
version bumps may contain breaking api changes.
homepage: https://github.com/nek0/affection#readme
license: LGPL-3
license-file: LICENSE
@ -49,7 +52,7 @@ library
, UndecidableInstances
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -Wall -debug
ghc-options: -Wall
-- Other library packages from which modules are imported.
build-depends: base >=4.9 && <4.10
, sdl2
@ -118,7 +121,7 @@ executable example02
executable example03
hs-source-dirs: examples
main-is: example03.hs
ghc-options: -threaded -Wall -auto-all -caf-all -rtsopts -debug
ghc-options: -threaded -Wall -auto-all -caf-all -rtsopts
default-language: Haskell2010
default-extensions: OverloadedStrings
if flag(examples)

4
examples/example00.hs
View file

@ -96,8 +96,8 @@ draw = do
liftIO $ SDL.unlockSurface drawSurface
liftIO $ SDL.updateWindowSurface drawWindow
update :: Double -> Affection UserData ()
update sec = do
update :: Double -> [SDL.Event] -> Affection UserData ()
update sec _ = do
traceM "updating"
ad <- get
ud@UserData{..} <- getAffection

4
examples/example01.hs
View file

@ -89,8 +89,8 @@ draw = do
drawRect (nodeGraph M.! "nop") (G.RGB 1 0 0) Fill (G.GeglRectangle 10 10 500 500) foreground
liftIO $ G.gegl_node_process $ nodeGraph M.! "sink"
update :: Double -> AffectionState (AffectionData UserData) IO ()
update sec = do
update :: Double -> [SDL.Event] -> Affection UserData ()
update sec _ = do
traceM "updating"
-- liftIO $ delaySec 5
ad <- get

10
examples/example02.hs
View file

@ -98,14 +98,14 @@ draw = do
) coordinates
liftIO $ G.gegl_node_process $ nodeGraph M.! "sink"
update :: Double -> AffectionState (AffectionData UserData) IO ()
update sec = do
update :: Double -> [SDL.Event] -> Affection UserData ()
update sec evs = do
traceM "updating"
ad <- get
ud <- getAffection
traceM $ (show $ 1 / sec) ++ " FPS"
ev <- liftIO $ SDL.pollEvent
maybe (return ()) (\e ->
-- ev <- liftIO $ SDL.pollEvent
mapM_ (\e ->
case SDL.eventPayload e of
SDL.MouseMotionEvent dat -> do
let (SDL.P (SDL.V2 x y)) = SDL.mouseMotionEventPos dat
@ -119,7 +119,7 @@ update sec = do
}
_ ->
return ()
) ev
) evs
clean :: UserData -> IO ()
clean _ = return ()

8
examples/example03.hs
View file

@ -103,15 +103,15 @@ draw = do
-- (G.GeglRectangle (x - 10) (y - 10) 20 20)
-- ) $ coordinates ud
update :: Double -> AffectionState (AffectionData UserData) IO ()
update sec = do
update :: Double -> [SDL.Event] -> Affection UserData ()
update sec evs = do
traceM "updating"
ad <- get
ud <- getAffection
-- let newPart = updateParticles sec partUpd $ particles ud
-- putAffection $ ud { particles = newPart }
traceM $ (show $ 1 / sec) ++ " FPS"
ev <- liftIO $ SDL.pollEvents
-- ev <- liftIO $ SDL.pollEvents
mapM_ (\e ->
case SDL.eventPayload e of
SDL.MouseMotionEvent dat ->
@ -171,7 +171,7 @@ update sec = do
}
_ ->
return ()
) ev
) evs
ud2 <- getAffection
nps <- updateParticleSystem (partsys ud2) sec partUpd partDraw
putAffection $ ud2 { partsys = nps }

61
src/Affection.hs
View file

@ -28,6 +28,8 @@ import Control.Concurrent.MVar
import Foreign.C.Types (CInt(..))
import Foreign.Storable (peek)
import Debug.Trace
import Affection.Types as A
import Affection.Draw as A
import Affection.Particle as A
@ -47,21 +49,15 @@ withAffection AffectionConfig{..} = do
G.gegl_init
execTime <- newMVar =<< getTime Monotonic
window <- SDL.createWindow windowTitle windowConfig
oldSurf@(SDL.Surface ptr _) <- SDL.getWindowSurface window
rawSurfacePtr <- Raw.convertSurfaceFormat ptr (SDL.toNumber SDL.ABGR8888) 0
let surface = (flip SDL.Surface Nothing) rawSurfacePtr
bablFormat = B.PixelFormat B.RGBA B.CFu8
pixels <- SDL.surfacePixels surface
-- let surface = (flip SDL.Surface Nothing) rawSurfacePtr
(oldSurf, surface) <- getSurfaces window
let bablFormat = B.PixelFormat B.RGBA B.CFu8
format <- B.babl_format bablFormat
SDL.V2 (CInt rw) (CInt rh) <- SDL.surfaceDimensions surface
pixelFormat <- peek . Raw.surfaceFormat =<< peek rawSurfacePtr
let (w, h) = (fromIntegral rw, fromIntegral rh)
stride = fromIntegral (Raw.pixelFormatBytesPerPixel pixelFormat) * w
cpp = B.babl_components_per_pixel bablFormat
initContainer <- (\x -> AffectionData
{ quitEvent = False
, userState = x
, drawWindow = window
, windowSurface = oldSurf
, drawSurface = surface
, drawFormat = format
, drawStack = []
@ -81,6 +77,14 @@ withAffection AffectionConfig{..} = do
-- get state
ad <- get
-- clean draw requests from last run
pixels <- SDL.surfacePixels $ drawSurface ad
(SDL.Surface ptr _) <- SDL.getWindowSurface window
rawSurfacePtr <- Raw.convertSurfaceFormat ptr (SDL.toNumber SDL.ABGR8888) 0
pixelFormat <- liftIO $ peek . Raw.surfaceFormat =<< peek rawSurfacePtr
SDL.V2 (CInt rw) (CInt rh) <- liftIO $ SDL.surfaceDimensions surface
let (w, h) = (fromIntegral rw, fromIntegral rh)
stride = fromIntegral (Raw.pixelFormatBytesPerPixel pixelFormat) * w
cpp = B.babl_components_per_pixel bablFormat
mapM_ (invalidateDrawRequest pixels stride cpp) $ drawStack ad
-- compute dt and update elapsedTime
let dt = (fromIntegral $ toNanoSecs $ diffTimeSpec lastTime now) / (fromIntegral 10 ^ 9)
@ -88,8 +92,10 @@ withAffection AffectionConfig{..} = do
{ drawStack = []
, elapsedTime = elapsedTime ad + dt
}
-- poll events
evs <- preHandleEvents =<< liftIO SDL.pollEvents
-- execute user defined update loop
updateLoop dt
updateLoop dt evs
-- execute user defined draw loop
drawLoop
-- handle all new draw requests
@ -99,7 +105,11 @@ withAffection AffectionConfig{..} = do
put $ ad2
{ drawStack = clear }
-- blit surface and update window
liftIO $ SDL.surfaceBlit surface Nothing oldSurf Nothing
liftIO $ SDL.surfaceBlit
(drawSurface ad2)
Nothing
(windowSurface ad2)
Nothing
liftIO $ SDL.updateWindowSurface $ drawWindow ad2
-- save new time
_ <- liftIO $ swapMVar execTime $ now
@ -110,6 +120,33 @@ withAffection AffectionConfig{..} = do
cleanUp $ userState nState
SDL.quit
getSurfaces :: SDL.Window -> IO (SDL.Surface, SDL.Surface)
getSurfaces window = do
oldSurf@(SDL.Surface ptr _) <- SDL.getWindowSurface window
rawSurfacePtr <- Raw.convertSurfaceFormat ptr (SDL.toNumber SDL.ABGR8888) 0
let surface = (flip SDL.Surface Nothing) rawSurfacePtr
return (oldSurf, surface)
preHandleEvents :: [SDL.Event] -> Affection us [SDL.Event]
preHandleEvents evs =
catMaybes <$> mapM handle evs
where
handle e =
case SDL.eventPayload e of
SDL.WindowMovedEvent _ -> do
liftIO $ traceIO "I was moved"
putNewSurface
return Nothing
_ ->
return $ Just e
putNewSurface = do
ad <- get
(oldSurf, surface) <- liftIO $ getSurfaces $ drawWindow ad
put ad
{ windowSurface = oldSurf
, drawSurface = surface
}
-- | Return the userstate to the user
getAffection :: Affection us us
getAffection = do

47
src/Affection/Particle.hs
View file

@ -39,21 +39,21 @@ updateParticle time funct pa = do
now <- elapsedTime <$> get
if particleCreation pa + particleTimeToLive pa < now
then do
-- mproducer <- liftIO $ G.gegl_node_get_producer
-- (particleStackCont pa)
-- "input"
-- case mproducer of
-- Just (producer, padname) -> do
-- consumers <- liftIO $ G.gegl_node_get_consumers
-- (particleStackCont pa)
-- "output"
-- liftIO $ mapM_ (\(node, inpad)-> G.gegl_node_connect_to
-- producer
-- padname
-- node
-- inpad
-- ) consumers
-- Nothing -> return ()
mproducer <- liftIO $ G.gegl_node_get_producer
(particleStackCont pa)
"input"
case mproducer of
Just (producer, padname) -> do
consumers <- liftIO $ G.gegl_node_get_consumers
(particleStackCont pa)
"output"
liftIO $ mapM_ (\(node, inpad)-> G.gegl_node_connect_to
producer
padname
node
inpad
) consumers
Nothing -> return ()
liftIO $ G.gegl_node_drop $ particleRootNode pa
return $ Nothing
else do
@ -119,9 +119,9 @@ updateParticleSystem sys sec upd draw = do
x <- catMaybes <$> mapM (updateParticle sec upd) (partStorList $ partSysParts sys)
-- x <- catMaybes <$> foldM (updateParticle sec upd) [] (reverse $ psParts sys)
when (not $ null x) $ do
liftIO $ G.gegl_node_link_many $ map particleStackCont (partStorList $ partSysParts sys)
-- liftIO $ G.gegl_node_link_many $ map particleStackCont (partStorList $ partSysParts sys)
-- liftIO $ traceIO "linking last node to output"
liftIO $ G.gegl_node_link (particleStackCont $ last x) (partSysNode sys)
liftIO $ G.gegl_node_link (particleStackCont $ head x) (partSysNode sys)
mapM_ (draw (partSysBuffer sys) (partSysNode sys)) x
return $ sys
{ partSysParts = (partSysParts sys)
@ -141,10 +141,11 @@ insertParticle
insertParticle ps p = do
now <- elapsedTime <$> get
let newList = chronoInsert now (partStorList $ partSysParts ps) p
when (not $ isNothing $ partStorLatest $ partSysParts ps) $
liftIO $ G.gegl_node_link
(particleStackCont p)
(particleStackCont $ fromJust $ partStorLatest $ partSysParts ps)
liftIO $ G.gegl_node_link_many (reverse $ map particleStackCont newList)
-- when (not $ isNothing $ partStorLatest $ partSysParts ps) $
-- liftIO $ G.gegl_node_link
-- (particleStackCont p)
-- (particleStackCont $ fromJust $ partStorLatest $ partSysParts ps)
return $ ps
{ partSysParts = (partSysParts ps)
{ partStorLatest = Just p
@ -160,10 +161,10 @@ chronoInsert
-> [Particle] -- ^ Resulting list
chronoInsert now [] np = [np]
chronoInsert now [p] np =
if now + particleTimeToLive p < particleCreation 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
if now + particleTimeToLive p < (particleCreation np + particleTimeToLive np)
then p : chronoInsert now ps np
else np : l

12
src/Affection/Types.hs
View file

@ -31,6 +31,7 @@ module Affection.Types
import qualified SDL.Init as SDL
import qualified SDL.Video as SDL
import qualified SDL.Event as SDL
import qualified Data.Text as T
import Data.Map
@ -55,7 +56,7 @@ data AffectionConfig us = AffectionConfig
-- ^ Actions to be performed, before loop starts
, drawLoop :: Affection us ()
-- ^ Function for updating graphics.
, updateLoop :: Double -> Affection us ()
, updateLoop :: Double -> [SDL.Event] -> Affection us ()
-- ^ Main update function. Takes fractions of a second as input.
, loadState :: SDL.Surface -> IO us
-- ^ Provide your own load function to create this data.
@ -74,6 +75,7 @@ data AffectionData us = AffectionData
{ quitEvent :: Bool -- ^ Loop breaker.
, userState :: us -- ^ State data provided by user
, drawWindow :: SDL.Window -- ^ SDL window
, windowSurface :: SDL.Surface -- ^ Internal surface of window
, drawSurface :: SDL.Surface -- ^ SDL surface
, drawFormat :: B.BablFormatPtr -- ^ Target format
, drawStack :: [DrawRequest] -- ^ Stack of 'DrawRequest's to be processed
@ -136,8 +138,10 @@ data RGBA = RGBA
-- | Type for defining the draw type of draw functions
data DrawType
= Fill -- ^ Fill the specified area completely with color
| Line -- ^ only draw the outline of the area
-- | Fill the specified area completely with color
= Fill
-- | only draw the outline of the area
| Line
{ lineWidth :: Int -- ^ Width of line in pixels
}
@ -187,7 +191,7 @@ data Particle = Particle
-- ^ 'G.GeglNode' to connect other 'Particle's to
, particleDrawFlange :: G.GeglNode
-- ^ 'G.GeglNode' to connect draw actions to
}
} deriving (Eq)
-- | The particle system
data ParticleSystem = ParticleSystem