affection/src/Affection.hs
nek0 678c830e33 example now working with the right colours
This was an issue with the default surface created by sdl, which had
the wrong color format. For the future it is advised to use the RGBA
CFu8 format from babl, or things may break again.
2016-11-08 04:31:51 +01:00

95 lines
2.7 KiB
Haskell

{-# LANGUAGE RecordWildCards #-}
module Affection
( withAffection
, withWindow
, withDefaultWindow
, delaySec
, get
, put
, module Affection.Render
, module Types
) where
import qualified SDL
import qualified SDL.Raw as Raw
import qualified GEGL as G
import qualified Data.Text as T
import Data.Maybe
import System.Clock
import Control.Monad.Loops
import Control.Monad.State
import Control.Monad.Reader
import Control.Concurrent.MVar
import Affection.Render
import Affection.Types as Types
-- | Main function which bootstraps everything else.
withAffection
:: AffectionConfig us -- ^ Configuration of the Game and its engine.
-> IO ()
withAffection conf@AffectionConfig{..} = do
case initComponents of
All ->
SDL.initializeAll
Only is ->
SDL.initialize is
G.gegl_init
execTime <- newMVar =<< getTime Monotonic
window <- SDL.createWindow windowTitle windowConfig
oldSurf@(SDL.Surface ptr vect) <- SDL.getWindowSurface window
surface <- (\x -> return $ SDL.Surface x Nothing) =<< Raw.convertSurfaceFormat ptr Raw.SDL_PIXELFORMAT_ABGR8888 0
initContainer <- return . (\x -> AffectionData
{ quitEvent = False
, userState = x
, drawWindow = window
, drawSurface = surface
}) =<< loadState surface
(res, nState) <- runStateT ( Types.runState $
whileM_ (do
current <- get
return $ not $ Types.quitEvent current
)
(do
liftIO $ SDL.surfaceBlit surface Nothing oldSurf Nothing
now <- liftIO $ getTime Monotonic
lastTime <- liftIO $ fromMaybe now <$> tryReadMVar execTime
drawLoop
updateLoop $ (fromIntegral $ toNanoSecs $ diffTimeSpec lastTime now) /
(fromIntegral 10 ^ 9)
_ <- liftIO $ swapMVar execTime $ now
return ()
)
) initContainer
G.gegl_exit
SDL.quit
-- | DEPRECATED!
-- Function for bootstraping a window.
withWindow :: Monad m => T.Text -> WindowConfig -> SDL.RendererConfig -> RenderT m a -> IO ()
withWindow title wconf rconf ops = do
window <- SDL.createWindow title wconf
-- I don't need a renderer here, i need a surface
renderer <- SDL.createRenderer window (-1) rconf
surface <- SDL.getWindowSurface window
G.gegl_init
-- I think I need some AffectionT or someting similar here and not a RenderT
-- from SDL.
inRender renderer $ ops
G.gegl_exit
SDL.destroyWindow window
-- | DEPRECATED!
-- Bootstrap a default window.
withDefaultWindow :: Monad m => T.Text -> (RenderT m a) -> IO ()
withDefaultWindow title ops = withWindow title defaultWindow SDL.defaultRenderer ops
-- | block a thread for a specified amount of time
delaySec
:: Int -- ^ Number of seconds
-> IO ()
delaySec dur = SDL.delay (fromIntegral $ dur * 1000)