123 lines
3.4 KiB
Haskell
123 lines
3.4 KiB
Haskell
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE BangPatterns #-}
|
|
module Affection
|
|
( withAffection
|
|
, get
|
|
, put
|
|
, module A
|
|
) where
|
|
|
|
import SDL (($=))
|
|
import qualified SDL
|
|
|
|
import System.Clock
|
|
|
|
import Control.Monad.Loops
|
|
import Control.Monad.State
|
|
|
|
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 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
|
|
-- 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
|
|
window <- SDL.createWindow windowTitle windowConfig
|
|
SDL.showWindow window
|
|
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
|
|
-- get current time
|
|
execTime <- getTime Monotonic
|
|
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
|
|
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
|
|
-- mapM_ eventLoop evs
|
|
eventLoop evs
|
|
-- execute user defined update loop
|
|
unless (pausedTime ad) (updateLoop dt)
|
|
-- execute user defined draw loop
|
|
liftIO $ GL.clear [ColorBuffer, DepthBuffer]
|
|
drawLoop
|
|
liftIO $ flush
|
|
-- handle all new draw requests
|
|
ad2 <- get
|
|
-- actual drawing
|
|
SDL.glSwapWindow window
|
|
-- save new time
|
|
ad3 <- get
|
|
when (sysTime ad == sysTime ad3) (
|
|
put ad3
|
|
{ sysTime = now
|
|
}
|
|
)
|
|
)
|
|
) initContainer
|
|
cleanUp $ userState nState
|
|
SDL.destroyWindow window
|
|
SDL.quit
|