module Main ( main, ) where import Control.Lens import Control.Monad import Control.Parallel import qualified Data.Map.Strict as M import Data.Preload.Render import qualified Data.Text as T import Dodge.Concurrent import Dodge.Config.Load import Dodge.Config.Update import Dodge.Data import Dodge.Event import Dodge.Initialisation import Dodge.LoadSeed import Dodge.Menu import Dodge.Render import Dodge.SoundLogic.LoadSound import Dodge.TestString import Dodge.Update import Graphics.Rendering.OpenGL hiding (color, rotate, scale, translate) import qualified IntMapHelp as IM import Loop import Music import Picture import Preload import Preload.Render import Render import qualified SDL import qualified SDL.Mixer as Mix import Sound import System.Directory 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 setupConLoop 20 (T.pack "Simple Game Loop") (winConfig sizex sizey (Just (posx, posy))) theCleanup (firstWorldLoad con) conEffects 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 pdata <- doPreload >>= applyWorldConfig theConfig --return $ startNewGame $ Universe cancontinue <- doesFileExist "saveSlot/0" mseed <- loadSeed return $ Universe { --{_uvWorld = initialWorld _uvWorld = splashScreen , _uvConfig = theConfig , _preloadData = pdata , _uvScreenLayers = [splashMenu] , _uvIOEffects = return , _uvTestString = testStringInit , _uvSideEffects = mempty , _uvCanContinue = cancontinue , _uvMSeed = mseed } 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 = case w ^. cWorld . timeFlow of NormalTimeFlow -> playSoundAndUpdate (_soundData $ _preloadData u) (_playingSounds w) (_toPlaySounds w) _ -> stopAllSounds >> return M.empty where w = _uvWorld u doSideEffects :: Universe -> IO Universe doSideEffects u = do let preData = _preloadData u newPlayingSounds <- playSoundUnlessRewinding u u' <- _uvIOEffects u 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 & uvIOEffects .~ 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)