pituicat/src/Affection.hs

137 lines
4.1 KiB
Haskell

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE BangPatterns #-}
module Affection
( withAffection
, get
, put
, liftIO
, module A
) where
import SDL (($=))
import qualified SDL
import qualified SDL.Raw.Video as SDL (glSetAttribute)
import qualified SDL.Raw.Enum as SDL
import System.Clock
import Control.Monad.Loops
import Control.Monad.State.Strict
import Control.Monad.IO.Class (liftIO)
import Foreign.C.Types (CInt(..))
import Debug.Trace
import Affection.Types as A
import Affection.StateMachine as A
import Affection.MouseInteractable as A
import Affection.Util as A
import Affection.MessageBus as A
import Affection.Subsystems as A
import Affection.Logging as A
import qualified Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..))
-- | Main function which bootstraps everything else.
withAffection
:: AffectionConfig us -- ^ Configuration of the Game and its engine.
-> IO ()
withAffection AffectionConfig{..} = do
liftIO $ logIO Debug "Affection starting"
liftIO $ logIO Debug "Initializing SDL"
-- intialiaze SDL
case initComponents of
All ->
SDL.initializeAll
Only is ->
SDL.initialize is
-- give SDL render quality
SDL.HintRenderScaleQuality SDL.$= SDL.ScaleLinear
-- just checking…
do
renderQuality <- SDL.get SDL.HintRenderScaleQuality
when (renderQuality /= SDL.ScaleLinear) $
logIO Warn "Linear texture filtering not enabled!"
-- construct window
liftIO $ logIO Debug "Creating Window"
window <- SDL.createWindow windowTitle windowConfig
SDL.showWindow window
_ <- SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1
context <- SDL.glCreateContext window
let SDL.V2 (CInt rw) (CInt rh) = SDL.windowInitialSize windowConfig
(w, h) = case canvasSize of
Just (cw, ch) -> (cw, ch)
Nothing -> (fromIntegral rw, fromIntegral rh)
SDL.setWindowMode window initScreenMode
-- SDL.swapInterval $= SDL.SynchronizedUpdates -- <- causes Problems with windows
liftIO $ logIO Debug "Getting Time"
-- get current time
execTime <- getTime Monotonic
liftIO $ logIO Debug "Loading initial data container"
initContainer <- (\x -> AffectionData
{ quitEvent = False
, userState = x
, drawWindow = window
, glContext = context
, drawDimensions = case canvasSize of
Just (cw, ch) -> (cw, ch)
Nothing -> (w, h)
, screenMode = initScreenMode
, elapsedTime = 0
, deltaTime = 0
, sysTime = execTime
, pausedTime = False
}) <$> loadState
(_, nState) <- runStateT ( A.runState $ do
liftIO $ logIO Debug "Starting Loop"
preLoop
whileM_ (do
current <- get
return $ not $ A.quitEvent current
)
(do
-- get state
ad <- get
-- Measure time difference form last run
now <- liftIO $ getTime Monotonic
let lastTime = sysTime ad
-- compute dt and update elapsedTime
let !dt = fromIntegral
(toNanoSecs $ diffTimeSpec lastTime now) / (10 ^ (9 :: Int))
!ne = elapsedTime ad + dt
put $ ad
{ elapsedTime = ne
, deltaTime = dt
}
-- poll events
evs <- preHandleEvents =<< liftIO SDL.pollEvents
-- handle events
eventLoop evs
-- execute user defined update loop
unless (pausedTime ad) (updateLoop dt)
-- execute user defined draw loop
liftIO $ GL.clear [GL.ColorBuffer, GL.DepthBuffer, GL.StencilBuffer]
drawLoop
liftIO GL.flush
-- actual displaying of newly drawn frame
SDL.glSwapWindow window
-- save new time
ad3 <- get
when (sysTime ad == sysTime ad3) (
put ad3
{ sysTime = now
}
)
)
) initContainer
liftIO $ logIO Debug "Loop ended. Cleaning"
cleanUp $ userState nState
liftIO $ logIO Debug "Destroying Window"
SDL.glDeleteContext context
SDL.destroyWindow window
-- SDL.quit -- <- This causes segfaults depending on hardware
liftIO $ logIO Debug "This is the end"