it compiles!
This commit is contained in:
parent
4d7f8fb354
commit
6ff8df056b
3 changed files with 23 additions and 14 deletions
|
@ -56,7 +56,7 @@ library
|
||||||
, mtl
|
, mtl
|
||||||
, gegl
|
, gegl
|
||||||
, monad-loops
|
, monad-loops
|
||||||
, timeit
|
, clock
|
||||||
-- , sdl2-image
|
-- , sdl2-image
|
||||||
|
|
||||||
executable example00
|
executable example00
|
||||||
|
|
|
@ -5,7 +5,7 @@ module Affection
|
||||||
, withDefaultWindow
|
, withDefaultWindow
|
||||||
, delaySec
|
, delaySec
|
||||||
, module Affection.Render
|
, module Affection.Render
|
||||||
, module Affection.Types
|
, module Types
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import qualified SDL
|
import qualified SDL
|
||||||
|
@ -14,7 +14,7 @@ import qualified GEGL as G
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
|
|
||||||
import System.TimeIt (timeItT)
|
import System.Clock
|
||||||
|
|
||||||
import Control.Monad.Loops
|
import Control.Monad.Loops
|
||||||
import Control.Monad.State
|
import Control.Monad.State
|
||||||
|
@ -31,21 +31,29 @@ withAffection conf@AffectionConfig{..} = do
|
||||||
SDL.initializeAll
|
SDL.initializeAll
|
||||||
Only is ->
|
Only is ->
|
||||||
SDL.initialize is
|
SDL.initialize is
|
||||||
execTime <- newMVar 0
|
execTime <- newMVar =<< getTime Monotonic
|
||||||
window <- SDL.createWindow windowTitle windowConfig
|
window <- SDL.createWindow windowTitle windowConfig
|
||||||
surface <- SDL.getWindowSurface window
|
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
|
state <- newMVar initContainer
|
||||||
(res, nState) <- runStateT (
|
(res, nState) <- runStateT ( Types.runState $
|
||||||
whileM_ (do
|
whileM_ (do
|
||||||
current <- get
|
current <- get
|
||||||
return $ Types.quitEvent current
|
return $ Types.quitEvent current
|
||||||
)
|
)
|
||||||
$ do
|
$ do
|
||||||
lastTime <- liftIO $ fromMaybe 0 <$> tryReadMVar execTime
|
now <- liftIO $ getTime Monotonic
|
||||||
(dTime, _) <- liftIO $ timeItT <$> drawLoop
|
lastTime <- liftIO $ fromMaybe now <$> tryReadMVar execTime
|
||||||
(uTime, _) <- liftIO $ timeItT <$> updateLoop lastTime
|
drawLoop
|
||||||
liftIO $ putMVar execTime $ lastTime + dTime + uTime
|
updateLoop $ (fromIntegral $ toNanoSecs $ diffTimeSpec lastTime now) /
|
||||||
|
(fromIntegral 10 ^ 9)
|
||||||
|
liftIO $ putMVar execTime $ now
|
||||||
) initContainer
|
) initContainer
|
||||||
SDL.quit
|
SDL.quit
|
||||||
|
|
||||||
|
|
|
@ -2,7 +2,7 @@
|
||||||
module Affection.Types
|
module Affection.Types
|
||||||
( AffectionData(..)
|
( AffectionData(..)
|
||||||
, AffectionConfig(..)
|
, AffectionConfig(..)
|
||||||
-- , AffectionState(..)
|
, AffectionState(..)
|
||||||
-- , AffectionDraw(..)
|
-- , AffectionDraw(..)
|
||||||
-- , Draw(..)
|
-- , Draw(..)
|
||||||
, AffectionStateInner(..)
|
, AffectionStateInner(..)
|
||||||
|
@ -30,7 +30,7 @@ data AffectionConfig us = AffectionConfig
|
||||||
, windowTitle :: T.Text -- ^ Window title
|
, windowTitle :: T.Text -- ^ Window title
|
||||||
, windowConfig :: SDL.WindowConfig -- ^ Window configuration
|
, windowConfig :: SDL.WindowConfig -- ^ Window configuration
|
||||||
, drawLoop :: AffectionState (AffectionData us) IO (IO ()) -- ^ Some function. Type to be determined.
|
, 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
|
, userData :: us
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -53,12 +53,13 @@ data InitComponents
|
||||||
| Only [SDL.InitFlag]
|
| Only [SDL.InitFlag]
|
||||||
|
|
||||||
-- | Inner 'StateT' monad for the update state
|
-- | 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
|
-- | Affection's state monad
|
||||||
newtype AffectionState us m a = AffectionState
|
newtype AffectionState us m a = AffectionState
|
||||||
{ runState :: AffectionStateInner us m a }
|
{ runState :: AffectionStateInner us m a }
|
||||||
deriving (Functor, Applicative, Monad, MonadIO)
|
deriving (Functor, Applicative, Monad, MonadIO, MonadState us)
|
||||||
|
|
||||||
-- -- | Inner 'StateT' monad of Affection
|
-- -- | Inner 'StateT' monad of Affection
|
||||||
-- type AffectionInner us od a = StateT (AffectionState us od) IO a
|
-- type AffectionInner us od a = StateT (AffectionState us od) IO a
|
||||||
|
|
Loading…
Reference in a new issue