144 lines
4.4 KiB
Haskell
144 lines
4.4 KiB
Haskell
module Main where
|
|
import Loop
|
|
import Shader
|
|
import LoadConfig
|
|
import Dodge.Default
|
|
import Dodge.Data
|
|
import Dodge.Initialisation
|
|
import Dodge.Rooms
|
|
import Dodge.Layout
|
|
import Dodge.LoadSound
|
|
import Dodge.Update
|
|
import Dodge.Event
|
|
import Dodge.Rendering
|
|
import Dodge.Menu
|
|
import Dodge.Floor
|
|
import Dodge.LoadConfig
|
|
import Dodge.LoadSound
|
|
import Picture
|
|
import Picture.Render
|
|
import Picture.Preload
|
|
import Sound
|
|
import Preload
|
|
import Sound.Preload
|
|
|
|
import Control.Concurrent
|
|
import Control.Lens
|
|
import Foreign (Word32)
|
|
|
|
import Control.Monad (when)
|
|
|
|
import System.Random
|
|
|
|
import qualified Data.Map as M
|
|
import qualified SDL
|
|
import qualified SDL.Mixer as Mix
|
|
import Graphics.Rendering.OpenGL hiding (color,scale,translate,rotate)
|
|
|
|
doPreload' :: IO (PreloadData a)
|
|
doPreload' = do
|
|
lChunks <- loadSounds
|
|
let sData = SoundData {_loadedChunks = lChunks, _playingSounds = M.empty}
|
|
rData <- preloadRender
|
|
return $ PreloadData rData sData 0
|
|
|
|
main :: IO ()
|
|
main = do
|
|
(sizex,sizey) <- loadConfig
|
|
keyConfig <- loadKeyConfig
|
|
setupLoop
|
|
(sizex,sizey)
|
|
(SDL.cursorVisible $= False >> doPreload' >>= resizeSpareFBO sizex sizey)
|
|
(\x -> (SDL.cursorVisible $= True) >> cleanUpPreload x)
|
|
(fmap (setWindowSize sizex sizey keyConfig) firstWorld)
|
|
( \preData w -> do
|
|
startTicks <- SDL.ticks
|
|
doTheRender preData w
|
|
playSoundQueue (_soundData preData) (_soundQueue w)
|
|
newSoundData <- playAndUpdate (_sounds w) (_soundData preData)
|
|
|
|
endTicks <- SDL.ticks
|
|
let lastFrameTicks = _frameTimer preData
|
|
renderFoldable
|
|
(_renderData preData)
|
|
(picToLTree Nothing . setLayer 1 . setDepth (-1)
|
|
. translate (-0.5) (-0.8) . scale 0.0005 0.0005
|
|
. text $ "ms/frame " ++ show (endTicks - lastFrameTicks)
|
|
)
|
|
return $ preData & soundData .~ newSoundData
|
|
& frameTimer .~ endTicks
|
|
)
|
|
(flip $ menuEvents handleEvent)
|
|
(Just . update)
|
|
Mix.closeAudio
|
|
|
|
checkForGlErrors :: IO ()
|
|
checkForGlErrors = do
|
|
errs <- errors
|
|
when (length errs > 0) $ putStrLn $ "GLerror during doLoop: " ++ unwords (map show errs)
|
|
|
|
setWindowSize :: Int -> Int -> KeyConfigSDL-> World -> World
|
|
setWindowSize x y z w = w & windowX .~ fromIntegral x
|
|
& windowY .~ fromIntegral y
|
|
& keyConfig .~ z
|
|
doTheRender :: PreloadData a -> World -> IO (Word32)
|
|
doTheRender preData w = do
|
|
sTicks <- SDL.ticks
|
|
clear [ColorBuffer,DepthBuffer]
|
|
let pdata = _renderData preData
|
|
rot = _cameraRot w
|
|
zoom = _cameraZoom w
|
|
trans@(tranx,trany) = _cameraCenter w
|
|
wins@(winx,winy) = (_windowX w,_windowY w)
|
|
wallPointsCol = wallsPointsAndCols w
|
|
windowPoints = wallsWindows w
|
|
lightPoints = lightsForGloom' w
|
|
viewFroms@(viewFromx,viewFromy) = _cameraViewFrom w
|
|
pic = worldPictures w
|
|
let wallPoints = map fst wallPointsCol
|
|
|
|
setCommonUniforms pdata rot zoom trans wins
|
|
|
|
depthFunc $= Just Less
|
|
|
|
pmat <- (newMatrix RowMajor
|
|
$ perspectiveMatrix rot zoom (tranx,trany) (winx,winy) (viewFromx,viewFromy)
|
|
) :: IO (GLmatrix GLfloat)
|
|
|
|
createLightMap pdata rot zoom trans wins wallPoints lightPoints viewFroms pmat
|
|
|
|
blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
|
|
clear [DepthBuffer]
|
|
|
|
renderBackground pdata rot zoom trans wins
|
|
|
|
renderWalls pdata wallPointsCol pmat
|
|
|
|
setWallDepth pdata wallPoints (viewFromx,viewFromy) pmat
|
|
|
|
depthFunc $= Just Lequal
|
|
|
|
renderFoldable pdata $ picToLTree (Just 0) pic
|
|
|
|
-- reset blend so that light map doesn't apply
|
|
-- blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
|
|
blendFuncSeparate $= ((SrcAlpha,OneMinusSrcAlpha) , (Zero,One))
|
|
-- blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
|
|
renderFoldable pdata $ picToLTree (Just 1) pic
|
|
|
|
-- set drawing for on top
|
|
blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
|
|
|
|
renderFoldable pdata $ picToLTree (Just 2) pic
|
|
|
|
depthMask $= Disabled
|
|
renderWalls pdata windowPoints pmat
|
|
depthMask $= Enabled
|
|
|
|
resetShaderUniforms (map extractProgAndUnis $ _listShaders pdata)
|
|
----------------------
|
|
blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
|
|
renderFoldable (_renderData preData) (picToLTree Nothing $ fixedCoordPictures w)
|
|
eTicks <- SDL.ticks
|
|
return (eTicks - sTicks)
|