2016-10-31 22:47:16 +00:00
|
|
|
{-# LANGUAGE RecordWildCards #-}
|
2017-02-23 23:18:29 +00:00
|
|
|
{-# LANGUAGE BangPatterns #-}
|
2016-03-25 08:41:22 +00:00
|
|
|
module Affection
|
2016-10-31 22:47:16 +00:00
|
|
|
( withAffection
|
2017-09-09 14:47:24 +00:00
|
|
|
, get
|
2017-11-04 17:35:09 +00:00
|
|
|
, put
|
2016-12-08 17:22:29 +00:00
|
|
|
, module A
|
2016-03-25 08:41:22 +00:00
|
|
|
) where
|
|
|
|
|
2017-10-03 10:47:18 +00:00
|
|
|
import SDL (($=))
|
2016-10-31 22:47:16 +00:00
|
|
|
import qualified SDL
|
|
|
|
|
2016-11-02 00:14:53 +00:00
|
|
|
import System.Clock
|
2016-10-31 22:47:16 +00:00
|
|
|
|
|
|
|
import Control.Monad.Loops
|
|
|
|
import Control.Monad.State
|
2016-03-25 10:43:31 +00:00
|
|
|
|
2016-12-11 16:38:03 +00:00
|
|
|
import Foreign.C.Types (CInt(..))
|
|
|
|
|
2017-02-17 16:15:06 +00:00
|
|
|
import Debug.Trace
|
|
|
|
|
2016-12-08 17:22:29 +00:00
|
|
|
import Affection.Types as A
|
2017-03-05 15:39:37 +00:00
|
|
|
import Affection.StateMachine as A
|
|
|
|
import Affection.MouseInteractable as A
|
2017-09-07 04:23:01 +00:00
|
|
|
import Affection.Util as A
|
2017-11-27 01:18:23 +00:00
|
|
|
import Affection.MessageBus as A
|
2016-03-25 15:58:46 +00:00
|
|
|
|
2017-09-09 14:47:24 +00:00
|
|
|
import Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..))
|
|
|
|
|
2016-12-11 16:38:03 +00:00
|
|
|
|
2016-11-06 04:02:06 +00:00
|
|
|
-- | Main function which bootstraps everything else.
|
|
|
|
withAffection
|
2017-11-27 22:30:11 +00:00
|
|
|
:: AffectionConfig us msg -- ^ Configuration of the Game and its engine.
|
2016-11-06 04:02:06 +00:00
|
|
|
-> IO ()
|
2016-11-08 04:15:44 +00:00
|
|
|
withAffection AffectionConfig{..} = do
|
2017-02-23 21:54:26 +00:00
|
|
|
-- intialiaze SDL
|
2016-10-31 22:47:16 +00:00
|
|
|
case initComponents of
|
|
|
|
All ->
|
|
|
|
SDL.initializeAll
|
|
|
|
Only is ->
|
|
|
|
SDL.initialize is
|
2017-02-23 21:54:26 +00:00
|
|
|
-- 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
|
2016-10-31 22:47:16 +00:00
|
|
|
window <- SDL.createWindow windowTitle windowConfig
|
2017-02-23 21:54:26 +00:00
|
|
|
SDL.showWindow window
|
2017-09-09 14:47:24 +00:00
|
|
|
context <- SDL.glCreateContext(window)
|
2017-10-03 10:47:18 +00:00
|
|
|
let SDL.V2 (CInt rw) (CInt rh) = SDL.windowInitialSize windowConfig
|
2017-03-23 03:32:43 +00:00
|
|
|
(w, h) = case canvasSize of
|
|
|
|
Just (cw, ch) -> (cw, ch)
|
|
|
|
Nothing -> (fromIntegral rw, fromIntegral rh)
|
2017-07-29 19:57:06 +00:00
|
|
|
SDL.setWindowMode window initScreenMode
|
2017-10-03 10:47:18 +00:00
|
|
|
SDL.swapInterval $= SDL.SynchronizedUpdates
|
2017-11-27 01:18:23 +00:00
|
|
|
-- get current time
|
2017-07-29 00:40:41 +00:00
|
|
|
execTime <- getTime Monotonic
|
2016-12-20 23:16:21 +00:00
|
|
|
initContainer <- (\x -> AffectionData
|
2016-11-04 15:06:16 +00:00
|
|
|
{ quitEvent = False
|
|
|
|
, userState = x
|
2016-11-02 00:14:53 +00:00
|
|
|
, drawWindow = window
|
2017-09-09 14:47:24 +00:00
|
|
|
, glContext = context
|
2017-03-23 03:32:43 +00:00
|
|
|
, drawDimensions = case canvasSize of
|
|
|
|
Just (cw, ch) -> (cw, ch)
|
|
|
|
Nothing -> (w, h)
|
2017-07-29 19:57:06 +00:00
|
|
|
, screenMode = initScreenMode
|
2016-12-25 07:14:51 +00:00
|
|
|
, elapsedTime = 0
|
2017-06-26 04:57:02 +00:00
|
|
|
, deltaTime = 0
|
2017-07-29 00:40:41 +00:00
|
|
|
, sysTime = execTime
|
|
|
|
, pausedTime = False
|
2017-03-23 03:34:04 +00:00
|
|
|
}) <$> loadState
|
2016-12-11 16:38:03 +00:00
|
|
|
(_, nState) <- runStateT ( A.runState $ do
|
2016-12-11 19:24:16 +00:00
|
|
|
preLoop
|
2016-10-31 22:47:16 +00:00
|
|
|
whileM_ (do
|
|
|
|
current <- get
|
2016-12-08 17:22:29 +00:00
|
|
|
return $ not $ A.quitEvent current
|
2016-10-31 22:47:16 +00:00
|
|
|
)
|
2016-11-04 15:06:16 +00:00
|
|
|
(do
|
2016-12-20 03:14:57 +00:00
|
|
|
-- get state
|
2016-12-11 16:38:03 +00:00
|
|
|
ad <- get
|
2017-07-29 00:40:41 +00:00
|
|
|
-- Measure time difference form last run
|
|
|
|
now <- liftIO $ getTime Monotonic
|
2017-07-29 00:51:18 +00:00
|
|
|
let lastTime = sysTime ad
|
2016-12-25 07:14:51 +00:00
|
|
|
-- compute dt and update elapsedTime
|
2017-11-29 16:49:56 +00:00
|
|
|
let !dt = fromIntegral
|
|
|
|
(toNanoSecs $ diffTimeSpec lastTime now) / (10 ^ (9 :: Int))
|
2017-02-23 23:18:29 +00:00
|
|
|
!ne = elapsedTime ad + dt
|
2016-12-11 16:38:03 +00:00
|
|
|
put $ ad
|
2017-10-03 10:47:18 +00:00
|
|
|
{ elapsedTime = ne
|
2017-06-26 04:57:02 +00:00
|
|
|
, deltaTime = dt
|
2016-12-25 07:14:51 +00:00
|
|
|
}
|
2017-02-17 16:15:06 +00:00
|
|
|
-- poll events
|
|
|
|
evs <- preHandleEvents =<< liftIO SDL.pollEvents
|
2017-03-28 22:46:03 +00:00
|
|
|
mapM_ eventLoop evs
|
2016-12-20 03:14:57 +00:00
|
|
|
-- execute user defined update loop
|
2017-07-29 00:51:18 +00:00
|
|
|
unless (pausedTime ad) (updateLoop dt)
|
2016-12-23 13:18:39 +00:00
|
|
|
-- execute user defined draw loop
|
2017-09-09 14:47:24 +00:00
|
|
|
liftIO $ GL.clear [ColorBuffer, DepthBuffer]
|
2016-12-23 13:18:39 +00:00
|
|
|
drawLoop
|
2017-09-09 14:47:24 +00:00
|
|
|
liftIO $ flush
|
2016-12-20 03:14:57 +00:00
|
|
|
-- handle all new draw requests
|
2016-12-20 04:27:35 +00:00
|
|
|
ad2 <- get
|
2017-02-23 21:54:26 +00:00
|
|
|
-- actual drawing
|
2017-09-09 14:47:24 +00:00
|
|
|
SDL.glSwapWindow window
|
2016-12-20 03:14:57 +00:00
|
|
|
-- save new time
|
2017-07-29 00:40:41 +00:00
|
|
|
ad3 <- get
|
2017-07-29 14:31:48 +00:00
|
|
|
when (sysTime ad == sysTime ad3) (
|
|
|
|
put ad3
|
|
|
|
{ sysTime = now
|
|
|
|
}
|
|
|
|
)
|
2016-11-04 15:06:16 +00:00
|
|
|
)
|
2016-10-31 22:47:16 +00:00
|
|
|
) initContainer
|
2016-11-13 12:39:25 +00:00
|
|
|
cleanUp $ userState nState
|
2017-02-23 21:54:26 +00:00
|
|
|
SDL.destroyWindow window
|
2016-10-31 22:47:16 +00:00
|
|
|
SDL.quit
|