diff --git a/appDodge/Main.hs b/appDodge/Main.hs index c75978005..d61492530 100644 --- a/appDodge/Main.hs +++ b/appDodge/Main.hs @@ -6,7 +6,7 @@ import Control.Lens import Control.Monad import Control.Parallel import qualified Data.Map.Strict as M -import Data.Preload.Render +--import Data.Preload.Render import qualified Data.Text as T import Dodge.Concurrent import Dodge.Config.Load @@ -24,10 +24,10 @@ import Graphics.Rendering.OpenGL hiding (color, rotate, scale, translate) import qualified IntMapHelp as IM import Loop import Music -import Picture +--import Picture import Preload import Preload.Render -import Render +--import Render import qualified SDL import qualified SDL.Mixer as Mix import Sound @@ -91,6 +91,8 @@ firstWorldLoad theConfig = do , _uvSideEffects = mempty , _uvCanContinue = cancontinue , _uvMSeed = mseed + , _uvLastFrameTicks = 0 + , _uvFrameTicks = 0 } return $ Universe @@ -104,15 +106,17 @@ firstWorldLoad theConfig = do , _uvSideEffects = mempty , _uvCanContinue = cancontinue , _uvMSeed = mseed + , _uvLastFrameTicks = 0 + , _uvFrameTicks = 0 } -theUpdateStep :: Universe -> IO Universe -theUpdateStep = doSideEffects <=< updateRenderSplit +theUpdateStep :: SDL.Window -> Universe -> IO Universe +theUpdateStep win = doSideEffects <=< updateRenderSplit win -updateRenderSplit :: Universe -> IO Universe -updateRenderSplit u = do +updateRenderSplit :: SDL.Window -> Universe -> IO Universe +updateRenderSplit win u = do let preData = _preloadData u - updateUniverse u `par` void (doDrawing (_renderData preData) u) + updateUniverse u `par` void (doDrawing win (_renderData preData) u) return $! updateUniverse u playSoundUnlessRewinding :: Universe -> IO (M.Map SoundOrigin Sound) @@ -124,37 +128,17 @@ playSoundUnlessRewinding u = case w ^. cWorld . timeFlow of 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 + & uvLastFrameTicks .~ (u ^. uvFrameTicks) + & uvFrameTicks .~ 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 @@ -166,7 +150,6 @@ doPreload = do { _renderData = rData , _soundData = SoundData{_loadedChunks = lChunks} , _musicData = MusicData{_loadedMusic = lMusic} - , _frameTimer = 0 } --checkForGlErrors :: IO () diff --git a/src/Data/Preload.hs b/src/Data/Preload.hs index 076d17f5d..1847ffe84 100644 --- a/src/Data/Preload.hs +++ b/src/Data/Preload.hs @@ -6,13 +6,11 @@ import Sound.Data import Music import Control.Lens -import GHC.Word (Word32) data PreloadData = PreloadData { _renderData :: RenderData , _soundData :: SoundData , _musicData :: MusicData - , _frameTimer :: Word32 } | DummyPdata diff --git a/src/Dodge/Data/Universe.hs b/src/Dodge/Data/Universe.hs index 7aad9d5ca..2d0e478ba 100644 --- a/src/Dodge/Data/Universe.hs +++ b/src/Dodge/Data/Universe.hs @@ -13,6 +13,7 @@ module Dodge.Data.Universe ( module Loop.Data, ) where +import GHC.Word (Word32) import Dodge.Data.SelectionList import Control.Lens --import qualified Data.Map.Strict as M @@ -34,6 +35,8 @@ data Universe = Universe , _uvTestString :: Universe -> [String] , _uvCanContinue :: Bool , _uvMSeed :: Maybe Int + , _uvLastFrameTicks :: Word32 + , _uvFrameTicks :: Word32 } data SideEffect diff --git a/src/Dodge/Render.hs b/src/Dodge/Render.hs index b173ee731..89727eb9b 100644 --- a/src/Dodge/Render.hs +++ b/src/Dodge/Render.hs @@ -3,6 +3,8 @@ module Dodge.Render ( doDrawing, ) where +import Picture.Base +import qualified SDL import qualified Data.Vector as V import Dodge.Render.Shadow import Control.Lens @@ -29,8 +31,8 @@ import Shader.ExtraPrimitive import Shader.Parameters import Shader.Poke -doDrawing :: RenderData -> Universe -> IO () -doDrawing pdata u = do +doDrawing :: SDL.Window -> RenderData -> Universe -> IO () +doDrawing win pdata u = do -- sTicks <- SDL.ticks let w = _uvWorld u cfig = _uvConfig u @@ -74,30 +76,6 @@ doDrawing pdata u = do (0, 0, 0) ws ) - -- ( pokeSPics - -- shadV - -- layerCounts - -- (_vboPtr $ _vaoVBO $ _shadVAO $ _shapeShader pdata) - -- (_eboPtr $ _shapeEBO pdata) - -- (_eboPtr $ _silhouetteEBO pdata) - -- (S.cons wallSPics $ worldSPic cfig w) - -- ) - -- <- MP.bindM3 (\ _ wlwifl counts -> return (wlwifl,counts)) - -- ( pokeBindFoldableLayer shadV layerCounts wp) - -- ( pokeWallsWindowsFloor - -- (shadVBOptr $ _wallTextureShader pdata) - -- (shadVBOptr $ _windowShader pdata) - -- (shadVBOptr $ _textureArrayShader pdata) - -- wallPointsCol - -- windowPoints - -- (_floorTiles w) - -- ) - -- ( pokeShape - -- (_vboPtr $ _vaoVBO $ _shadVAO $ _shapeShader pdata) - -- (_eboPtr $ _shapeEBO pdata) - -- (_eboPtr $ _silhouetteEBO pdata) - -- ws - -- ) -- bind wall points, silhouette data, surface geometry bindShaderLayers shadV layerCounts uncurry bindShaderBuffers $ @@ -293,9 +271,29 @@ doDrawing pdata u = do renderLayer FixedCoordLayer shadV layerCounts renderFoldable shadV $ fixedCoordPictures u depthMask $= Enabled + when (debugOn Show_ms_frame $ _uvConfig u) $ + renderFoldable + (_pictureShaders pdata) + ( setDepth (-1) + . translate (-0.5) (-0.8) + . scale 0.0005 0.0005 + $ fpsText (u ^. uvFrameTicks - u ^. uvLastFrameTicks) + ) + SDL.glSwapWindow win -- eTicks <- SDL.ticks -- return (eTicks - sTicks) +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 + + -------------------------------------------------------------------------------- -- note: currently assume there is only one UBO, we only bind it once at setup bufferUBO :: [Float] -> IO () diff --git a/src/Dodge/Render/Shadow.hs b/src/Dodge/Render/Shadow.hs new file mode 100644 index 000000000..70aa1a16e --- /dev/null +++ b/src/Dodge/Render/Shadow.hs @@ -0,0 +1,96 @@ +module Dodge.Render.Shadow where + +import Shader.Parameters +import Shader.ExtraPrimitive +import Graphics.Rendering.OpenGL (currentProgram, ($=), bindVertexArrayObject, bindBuffer + , BufferTarget (..), bufferSubData, TransferDirection (..) + ) +import Graphics.GL.Core43 +import Geometry +import Linear.V3 (cross) +--import Data.Vector.Unboxed as UV +import qualified Data.Vector as V +import Shader.Data +import Foreign +import Shape.Data +import Data.Preload.Render +--import Dodge.Data.Universe +import Control.Lens +import qualified Data.Vector.Fusion.Stream.Monadic as VFSM + +drawCPUShadows :: RenderData -> Shape -> Point3 -> Float -> IO () +drawCPUShadows pdata s pos rad = do + let theshad = pdata ^. positionalBlankShader + theptr = _vboPtr $ _vaoVBO $ _shadVAO theshad + i <- VFSM.foldlM' (pokeShapeShad pos rad theptr) 0 $ VFSM.fromList s + bindBuffer ArrayBuffer $= (theshad ^? shadVAO . vaoVBO . vbo) + bufferSubData + ArrayBuffer + WriteToBuffer + 0 + (fromIntegral $ floatSize * i) + (theshad ^. shadVAO . vaoVBO . vboPtr) + currentProgram $= theshad ^? shadProg + bindVertexArrayObject $= Just (_vao $ _shadVAO theshad) + glDrawArrays + (marshalEPrimitiveMode $ _shadPrim theshad) + 0 + (fromIntegral i) + return () + +pokeShapeShad :: Point3 -> Float -> Ptr Float -> Int -> ShapeObj -> IO Int +pokeShapeShad pos r theptr i so = do + let vs = V.fromList $ map _svPos (_shVs so) + is = memoTopPrismEdges V.! (so ^. shType . prismSize - 2) + V.foldM' (pokeShadEdge pos r theptr vs) i is + +pokeShadEdge :: Point3 -> Float -> Ptr Float -> V.Vector Point3 + -> Int -> (Int,Int,Int,Int) -> IO Int +pokeShadEdge pos _ ptr vxs i (a,b,x,y) = do + let p0 = vxs V.! a + p1 = vxs V.! b + --mid = 0.5 * (p0 + p1) + n0a = vxs V.! x + n1a = vxs V.! y -- this should almost certainly be done with backpermute + n0 = cross (p1 - p0) (n0a - p0) + n1 = cross (p0 - p1) (n1a - p1) + lightdir = p0 - pos + shift' p = p + (10000 *.*.* (p - pos)) +-- projNear p = +-- shiftNear p = + if dotV3 n0 lightdir * dotV3 n1 lightdir <=0 + then do + let p2 = shift' p0 + p3 = shift' p1 + if dotV3 n0 lightdir > 0 + then + pokeV3 ptr p0 i >>= pokeV3 ptr p1 >>= pokeV3 ptr p2 + >>= pokeV3 ptr p0 >>= pokeV3 ptr p2 >>= pokeV3 ptr p3 + else + pokeV3 ptr p1 i >>= pokeV3 ptr p0 >>= pokeV3 ptr p3 + >>= pokeV3 ptr p1 >>= pokeV3 ptr p3 >>= pokeV3 ptr p2 + else + return i + +pokeV3 :: Ptr Float -> Point3 -> Int -> IO Int +pokeV3 ptr (V3 x y z) i = do + pokeElemOff ptr (3 * i) x + pokeElemOff ptr (3 * i + 1) y + pokeElemOff ptr (3 * i + 2) z + return (i + 1) + +memoTopPrismEdges :: V.Vector (V.Vector (Int,Int,Int,Int)) +memoTopPrismEdges = V.generate 10 + $ V.fromList . topPrismEdges . (+ 2) + +topPrismEdges :: Int -> [(Int,Int,Int,Int)] +topPrismEdges n = concatMap f [0..n-1] + where + f i = map h + [ (0 , 2 , 1 , 4) + , (0 , 1 ,-2 , 3) + , (1 , 3 ,-1 , 2) + ] + where + h (a,b,c,d) = (g a,g b,g c, g d) + g j = (2 * i + j) `mod` (2*n) diff --git a/src/Loop.hs b/src/Loop.hs index e02a6661f..388d20feb 100644 --- a/src/Loop.hs +++ b/src/Loop.hs @@ -200,7 +200,8 @@ setupConLoop' :: ---- | Concurrent effects. Evaluating 'Nothing' exits the loop (world -> ConcurrentEffect world) -> -- | update, called once per frame. Allows for side effects such as rendering. - (world -> IO world) -> + -- passes the window to allow buffer swapping + (Window -> world -> IO world) -> -- | SDL Event handling, once per frame. Note no side effects. (world -> Event -> world) -> IO () @@ -232,7 +233,7 @@ doConLoop' :: (world -> ConcurrentEffect world) -> -- | simulation update. Allows for side effects such as rendering. -- passes the window to allow buffer swapping at different times - (world -> IO world) -> + (Window -> world -> IO world) -> -- | SDL Event handling. Note no side effects. (world -> Event -> world) -> -- | Current simulation state. @@ -240,6 +241,7 @@ doConLoop' :: IO () doConLoop' themvar spf window coneffs worldSideEffects eventFn !startWorld = go startWorld where + worldSideEffectsWindow = worldSideEffects window go sw = do startTicks <- ticks es <- pollEvents @@ -258,8 +260,8 @@ doConLoop' themvar spf window coneffs worldSideEffects eventFn !startWorld = go case mstartWorld' of Nothing -> return () Just startWorld' -> do - worldAfterSimStep <- worldSideEffects startWorld' - glSwapWindow window + worldAfterSimStep <- worldSideEffectsWindow startWorld' +-- glSwapWindow window let updatedWorld = foldl' eventFn worldAfterSimStep es performGC endTicks <- ticks -- it might be better to use System.Clock (monotonic)