pituicat/src/Affection.hs
2017-11-27 02:18:23 +01:00

129 lines
3.5 KiB
Haskell

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE BangPatterns #-}
module Affection
( withAffection
, get
, getAffection
, putAffection
, delaySec
, get
, put
, module A
) where
import SDL (($=))
import qualified SDL
import qualified SDL.Internal.Numbered as SDL (toNumber)
import qualified SDL.Raw as Raw
import Data.Maybe
import Data.IORef
import System.Clock
import Control.Monad.Loops
import Control.Monad.State
import Foreign.C.Types (CInt(..))
import Foreign.Storable (peek)
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 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) $
putStrLn "Warning: 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)
!ne = elapsedTime ad + dt
put $ ad
{ elapsedTime = ne
, deltaTime = dt
}
-- poll events
evs <- preHandleEvents =<< liftIO SDL.pollEvents
mapM_ 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