it works only halfway

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

View file

@ -6,9 +6,12 @@ name: affection
-- PVP summary: +-+------- breaking API changes -- PVP summary: +-+------- breaking API changes
-- | | +----- non-breaking API additions -- | | +----- non-breaking API additions
-- | | | +--- code changes with no API change -- | | | +--- code changes with no API change
version: 0.0.0.0 version: 0.0.0.1
synopsis: A simple Game Engine using SDL 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 homepage: https://github.com/nek0/affection#readme
license: LGPL-3 license: LGPL-3
license-file: LICENSE license-file: LICENSE
@ -49,7 +52,7 @@ library
, UndecidableInstances , UndecidableInstances
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall -debug ghc-options: -Wall
-- Other library packages from which modules are imported. -- Other library packages from which modules are imported.
build-depends: base >=4.9 && <4.10 build-depends: base >=4.9 && <4.10
, sdl2 , sdl2
@ -118,7 +121,7 @@ executable example02
executable example03 executable example03
hs-source-dirs: examples hs-source-dirs: examples
main-is: example03.hs 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-language: Haskell2010
default-extensions: OverloadedStrings default-extensions: OverloadedStrings
if flag(examples) if flag(examples)

View file

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

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 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" liftIO $ G.gegl_node_process $ nodeGraph M.! "sink"
update :: Double -> AffectionState (AffectionData UserData) IO () update :: Double -> [SDL.Event] -> Affection UserData ()
update sec = do update sec _ = do
traceM "updating" traceM "updating"
-- liftIO $ delaySec 5 -- liftIO $ delaySec 5
ad <- get ad <- get

View file

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

View file

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

View file

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

View file

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

View file

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