82 lines
2.3 KiB
Haskell
82 lines
2.3 KiB
Haskell
{-# LANGUAGE RecordWildCards #-}
|
|
module Affection
|
|
( withAffection
|
|
, withWindow
|
|
, withDefaultWindow
|
|
, delaySec
|
|
, get
|
|
, put
|
|
, module Affection.Render
|
|
, module Types
|
|
) where
|
|
|
|
import qualified SDL
|
|
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
|
|
|
|
withAffection :: AffectionConfig us -> 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
|
|
surface <- SDL.getWindowSurface window
|
|
initContainer <- return . (\x -> AffectionData
|
|
-- { affectionConfig = conf
|
|
{ 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
|
|
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
|
|
|
|
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
|
|
|
|
withDefaultWindow :: Monad m => T.Text -> (RenderT m a) -> IO ()
|
|
withDefaultWindow title ops = withWindow title defaultWindow SDL.defaultRenderer ops
|
|
|
|
delaySec :: Int -> IO ()
|
|
delaySec dur = SDL.delay (fromIntegral $ dur * 1000)
|