138 lines
5.1 KiB
Haskell
138 lines
5.1 KiB
Haskell
module Loop
|
|
( setupLoop
|
|
-- , withExits
|
|
) where
|
|
import SDL
|
|
import qualified Data.Text as T
|
|
import Control.Concurrent
|
|
import Control.Exception
|
|
import qualified Graphics.Rendering.OpenGL as GL
|
|
import Control.Monad
|
|
import System.Mem
|
|
import Foreign.C
|
|
import Geometry
|
|
|
|
import Preload
|
|
|
|
import Control.Lens ((.~),(&),(+~))
|
|
|
|
winConfig x y = defaultWindow
|
|
{ windowGraphicsContext
|
|
= OpenGLContext (defaultOpenGL { glProfile = Core Normal 4 3
|
|
, glColorPrecision = V4 8 8 8 8
|
|
}
|
|
)
|
|
, windowInitialSize = V2 x y
|
|
, windowResizable =True
|
|
}
|
|
|
|
--setupLoop :: String
|
|
-- -> CInt
|
|
-- -> CInt
|
|
-- -> IO setupParams
|
|
-- -> (setupParams -> IO ())
|
|
-- -> world
|
|
-- -> (setupParams -> world -> IO setupParams)
|
|
-- -> (world -> Event -> Maybe world)
|
|
-- -> (world -> Maybe world)
|
|
-- -> IO ()
|
|
setupLoop :: String
|
|
-> CInt
|
|
-> CInt
|
|
-> IO (PreloadData a)
|
|
-> (PreloadData a -> IO ())
|
|
-> world
|
|
-> (PreloadData a -> world -> IO (PreloadData a))
|
|
-> (world -> Event -> Maybe world)
|
|
-> (world -> Maybe world)
|
|
-> IO ()
|
|
setupLoop wName xSize ySize
|
|
customInit initCleanup startWorld sideEffects eventFn worldFn = do
|
|
initializeAll
|
|
bracket (createWindow (T.pack wName) (winConfig xSize ySize)) destroyWindow
|
|
(\window ->
|
|
do bracket (glCreateContext window) (\con -> GL.finish >> glDeleteContext con)
|
|
(\_ -> bracket customInit initCleanup $ \setup -> do -- setup <- customInit
|
|
-- swapInterval $= ImmediateUpdates
|
|
GL.blend $= GL.Enabled
|
|
GL.depthMask $= GL.Enabled
|
|
GL.blendEquation $= GL.FuncAdd
|
|
GL.blendFunc $= (GL.SrcAlpha,GL.OneMinusSrcAlpha)
|
|
GL.clearColor $= GL.Color4 0 0.5 0 1
|
|
GL.clearDepth $= (200)
|
|
doLoop setup window startWorld
|
|
sideEffects eventFn worldFn
|
|
)
|
|
)
|
|
|
|
|
|
--doLoop :: setupParams -> Window -> WorldView world0
|
|
-- -> (setupParams -> WorldView world0 -> IO ())
|
|
-- -> (world0 -> Event -> Maybe world0)
|
|
-- -> (world0 -> Maybe world0)
|
|
-- -> IO ()
|
|
doLoop setup window startWorld
|
|
worldSideEffects
|
|
eventFn
|
|
worldUpdate
|
|
= do
|
|
startLoopTicks <- ticks
|
|
GL.clear [GL.ColorBuffer,GL.DepthBuffer]
|
|
newParams <- worldSideEffects (setup & currentTime .~ startLoopTicks) startWorld
|
|
glSwapWindow window
|
|
endSideTicks <- ticks
|
|
--worldSideEffects setup updatedWorld
|
|
events <- pollEvents
|
|
--let-- maybeUpdatedWorld :: Maybe (WorldView world0)
|
|
-- maybeUpdatedWorld = applyEvents eventFn startWorld events worldUpdate
|
|
maybeUpdatedWorld <- applyEventsIO eventFn startWorld events
|
|
case maybeUpdatedWorld >>= worldUpdate of
|
|
Just updatedWorld -> do
|
|
--GL.clear [GL.ColorBuffer,GL.DepthBuffer]
|
|
--worldSideEffects setup updatedWorld
|
|
--glSwapWindow window
|
|
--GL.flush
|
|
endSimTicks <- ticks
|
|
performGC
|
|
endLoopTicks <- ticks -- it might be better to use System.Clock (monotonic)
|
|
let delay = max 0 (10 + fromIntegral startLoopTicks - fromIntegral endLoopTicks)
|
|
threadDelay (delay * 1000)
|
|
endTime <- ticks
|
|
let newNewParams = newParams & idleTime +~ (endTime - endLoopTicks)
|
|
& gcTime +~ (endLoopTicks - endSimTicks)
|
|
& simTime +~ (endSimTicks - endSideTicks)
|
|
doLoop newNewParams window updatedWorld worldSideEffects eventFn worldUpdate
|
|
Nothing -> showTiming setup
|
|
|
|
applyEvents :: (world0 -> Event -> Maybe world0)
|
|
-> world0
|
|
-> [Event]
|
|
-> (world0 -> Maybe world0)
|
|
-> Maybe world0
|
|
applyEvents eventFn startWorld events worldUpdate =
|
|
case foldM (applyH eventFn) startWorld events of
|
|
Just w -> fmap (\w' -> w') $ worldUpdate w
|
|
Nothing -> Nothing
|
|
where
|
|
applyH :: (world0 -> Event -> Maybe world0) -> world0 -> Event -> Maybe world0
|
|
applyH f w e
|
|
= case eventPayload e of
|
|
QuitEvent -> Nothing
|
|
WindowClosedEvent _ -> Nothing
|
|
_ -> f w e
|
|
|
|
applyEventIO :: (world -> Event -> Maybe world) -> Maybe world -> Event -> IO (Maybe world)
|
|
applyEventIO fn mw e = case eventPayload e of
|
|
QuitEvent -> return Nothing
|
|
WindowClosedEvent _ -> return Nothing
|
|
WindowSizeChangedEvent
|
|
(WindowSizeChangedEventData {windowSizeChangedEventSize = V2 x y})
|
|
-> GL.viewport $= (GL.Position 0 0,GL.Size x y) >> return (mw >>= \w -> fn w e)
|
|
_ -> return $ mw >>= flip fn e
|
|
|
|
applyEventsIO :: (world0 -> Event -> Maybe world0)
|
|
-> world0
|
|
-> [Event]
|
|
-> IO (Maybe world0)
|
|
applyEventsIO fn w es = foldM (applyEventIO fn) (Just w) es
|