150 lines
4.6 KiB
Haskell
150 lines
4.6 KiB
Haskell
module Main
|
|
( main
|
|
) where
|
|
import Loop
|
|
import Dodge.TestString
|
|
import Dodge.Data
|
|
import Dodge.StartNewGame
|
|
import Dodge.Initialisation
|
|
--import Dodge.LevelGen
|
|
import Dodge.Update
|
|
import Dodge.Event
|
|
import Dodge.Render
|
|
import Dodge.Config.KeyConfig
|
|
import Dodge.Config.Load
|
|
import Dodge.Config.Update
|
|
import Dodge.SoundLogic.LoadSound
|
|
import Picture
|
|
import Render
|
|
import Preload.Render
|
|
import Sound
|
|
import Preload
|
|
import Music
|
|
import Data.Preload
|
|
import Data.Preload.Render
|
|
|
|
import Control.Lens
|
|
import Control.Monad
|
|
--import Control.Monad.Parallel
|
|
import qualified Data.Text as T
|
|
import qualified IntMapHelp as IM
|
|
import Graphics.Rendering.OpenGL hiding (color, rotate, scale, translate)
|
|
import qualified SDL
|
|
import qualified SDL.Mixer as Mix
|
|
import Control.Parallel
|
|
import qualified Data.Map.Strict as M
|
|
|
|
main :: IO ()
|
|
main = do
|
|
-- load the config to get the window size and position
|
|
con <- loadDodgeConfig
|
|
let sizex = floor $ _windowX con
|
|
sizey = floor $ _windowY con
|
|
posx = _windowPosX con
|
|
posy = _windowPosY con
|
|
setupLoop
|
|
20
|
|
(T.pack "Simple Game Loop")
|
|
(winConfig sizex sizey (Just (posx,posy)))
|
|
theCleanup
|
|
(firstWorldLoad con)
|
|
theUpdateStep
|
|
(flip handleEvent)
|
|
|
|
-- | Create an OpenGL SDL window configuration with a given x and y size.
|
|
winConfig :: Int -> Int -> Maybe (Int, Int) -> SDL.WindowConfig
|
|
winConfig x y winpos = SDL.defaultWindow
|
|
{ SDL.windowGraphicsContext = SDL.OpenGLContext $ SDL.defaultOpenGL
|
|
{ SDL.glProfile = SDL.Core SDL.Normal 4 3
|
|
, SDL.glColorPrecision = SDL.V4 8 8 8 8
|
|
}
|
|
, SDL.windowPosition = theWinPos
|
|
, SDL.windowInitialSize = SDL.V2 (fromIntegral x) (fromIntegral y)
|
|
, SDL.windowResizable = True
|
|
}
|
|
where
|
|
theWinPos = case winpos of
|
|
Just (px,py) -> SDL.Absolute (SDL.P (SDL.V2 (fromIntegral px) (fromIntegral py)))
|
|
Nothing -> SDL.Wherever
|
|
|
|
theCleanup :: Universe -> IO ()
|
|
theCleanup uv = SDL.cursorVisible $= True >> cleanUpPreload (_preloadData uv)
|
|
|
|
firstWorldLoad :: Configuration -> IO Universe
|
|
firstWorldLoad theConfig = do
|
|
SDL.cursorVisible $= False
|
|
theKeyConfig <- loadKeyConfig
|
|
pdata <- doPreload >>= applyWorldConfig theConfig
|
|
return $ startNewGame $ Universe
|
|
{_uvWorld = initialWorld
|
|
,_uvConfig = theConfig
|
|
,_preloadData = pdata
|
|
,_menuLayers = []
|
|
,_savedWorlds = M.empty
|
|
,_keyConfig = theKeyConfig
|
|
, _uvTestString = testStringInit
|
|
}
|
|
|
|
theUpdateStep :: Universe -> IO Universe
|
|
theUpdateStep = doSideEffects <=< updateRenderSplit
|
|
|
|
updateRenderSplit :: Universe -> IO Universe
|
|
updateRenderSplit u = do
|
|
let preData = _preloadData u
|
|
updateUniverse u `par` void (doDrawing (_renderData preData) u)
|
|
return (updateUniverse u)
|
|
|
|
playSoundUnlessRewinding :: Universe -> IO (M.Map SoundOrigin Sound)
|
|
playSoundUnlessRewinding u
|
|
| _timeFlow w == RewindingNow = return M.empty
|
|
| otherwise = playSoundAndUpdate (_soundData $ _preloadData u) (_playingSounds w) (_toPlaySounds w)
|
|
where
|
|
w = _uvWorld u
|
|
|
|
doSideEffects :: Universe -> IO Universe
|
|
doSideEffects u = do
|
|
let w = _uvWorld u
|
|
let preData = _preloadData u
|
|
newPlayingSounds <- playSoundUnlessRewinding u
|
|
u' <- _sideEffects w u
|
|
endTicks <- SDL.ticks
|
|
let lastFrameTicks = _frameTimer preData
|
|
when (debugOn Show_ms_frame $ _uvConfig u) $ void $ renderFoldable
|
|
(_pictureShaders $ _renderData preData)
|
|
(setDepth (-1)
|
|
. translate (-0.5) (-0.8) . scale 0.0005 0.0005
|
|
$ fpsText (endTicks - lastFrameTicks)
|
|
)
|
|
return $ u'
|
|
& preloadData . frameTimer .~ endTicks
|
|
& uvWorld . playingSounds .~ newPlayingSounds
|
|
& uvWorld . toPlaySounds .~ M.empty
|
|
& uvWorld . sideEffects .~ return
|
|
|
|
fpsText :: (Show a, Ord a, Num a) => a -> Picture
|
|
fpsText x = color col $ text $ "ms/frame " ++ show x
|
|
where
|
|
col | x < 22 = blue
|
|
| x < 30 = green
|
|
| x < 40 = yellow
|
|
| x < 50 = orange
|
|
| otherwise = red
|
|
|
|
doPreload :: IO PreloadData
|
|
doPreload = do
|
|
rData <- preloadRender
|
|
lChunks <- loadSounds
|
|
lMusic <- loadMusic
|
|
Mix.playMusic Mix.Forever (lMusic IM.! 0)
|
|
return PreloadData
|
|
{ _renderData = rData
|
|
, _soundData = SoundData {_loadedChunks = lChunks}
|
|
, _musicData = MusicData {_loadedMusic = lMusic}
|
|
, _frameTimer = 0
|
|
}
|
|
|
|
--checkForGlErrors :: IO ()
|
|
--checkForGlErrors = do
|
|
-- errs <- errors
|
|
-- unless (null errs) $ putStrLn $ "GLerror during doLoop: " ++ unwords (map show errs)
|