diff --git a/affection.cabal b/affection.cabal index 1155bd4..4fbe4c3 100644 --- a/affection.cabal +++ b/affection.cabal @@ -56,7 +56,7 @@ library , mtl , gegl , monad-loops - , timeit + , clock -- , sdl2-image executable example00 diff --git a/src/Affection.hs b/src/Affection.hs index b09b42c..ce4aad1 100644 --- a/src/Affection.hs +++ b/src/Affection.hs @@ -5,7 +5,7 @@ module Affection , withDefaultWindow , delaySec , module Affection.Render - , module Affection.Types + , module Types ) where import qualified SDL @@ -14,7 +14,7 @@ import qualified GEGL as G import qualified Data.Text as T import Data.Maybe -import System.TimeIt (timeItT) +import System.Clock import Control.Monad.Loops import Control.Monad.State @@ -31,21 +31,29 @@ withAffection conf@AffectionConfig{..} = do SDL.initializeAll Only is -> SDL.initialize is - execTime <- newMVar 0 + execTime <- newMVar =<< getTime Monotonic window <- SDL.createWindow windowTitle windowConfig surface <- SDL.getWindowSurface window - let initContainer = AffectionData conf False userData window surface + initContainer <- return $ AffectionData + { affectionConfig = conf + , quitEvent = False + , userState = userData + , drawWindow = window + , drawSurface = surface + } state <- newMVar initContainer - (res, nState) <- runStateT ( + (res, nState) <- runStateT ( Types.runState $ whileM_ (do current <- get return $ Types.quitEvent current ) $ do - lastTime <- liftIO $ fromMaybe 0 <$> tryReadMVar execTime - (dTime, _) <- liftIO $ timeItT <$> drawLoop - (uTime, _) <- liftIO $ timeItT <$> updateLoop lastTime - liftIO $ putMVar execTime $ lastTime + dTime + uTime + now <- liftIO $ getTime Monotonic + lastTime <- liftIO $ fromMaybe now <$> tryReadMVar execTime + drawLoop + updateLoop $ (fromIntegral $ toNanoSecs $ diffTimeSpec lastTime now) / + (fromIntegral 10 ^ 9) + liftIO $ putMVar execTime $ now ) initContainer SDL.quit diff --git a/src/Affection/Types.hs b/src/Affection/Types.hs index 44eebc2..3cf0e65 100644 --- a/src/Affection/Types.hs +++ b/src/Affection/Types.hs @@ -2,7 +2,7 @@ module Affection.Types ( AffectionData(..) , AffectionConfig(..) - -- , AffectionState(..) + , AffectionState(..) -- , AffectionDraw(..) -- , Draw(..) , AffectionStateInner(..) @@ -30,7 +30,7 @@ data AffectionConfig us = AffectionConfig , windowTitle :: T.Text -- ^ Window title , windowConfig :: SDL.WindowConfig -- ^ Window configuration , drawLoop :: AffectionState (AffectionData us) IO (IO ()) -- ^ Some function. Type to be determined. - , updateLoop :: Double -> AffectionState us IO (IO ()) -- ^ Another function. Type to be determined + , updateLoop :: Double -> AffectionState (AffectionData us) IO (IO ()) -- ^ main update function. Takes nanoseconds as input. , userData :: us } @@ -53,12 +53,13 @@ data InitComponents | Only [SDL.InitFlag] -- | Inner 'StateT' monad for the update state -type AffectionStateInner us m a = StateT (AffectionData us) m a +-- type AffectionStateInner us m a = StateT (AffectionData us) m a +type AffectionStateInner us m a = StateT us m a -- | Affection's state monad newtype AffectionState us m a = AffectionState { runState :: AffectionStateInner us m a } - deriving (Functor, Applicative, Monad, MonadIO) + deriving (Functor, Applicative, Monad, MonadIO, MonadState us) -- -- | Inner 'StateT' monad of Affection -- type AffectionInner us od a = StateT (AffectionState us od) IO a