Add file, move buffer swapping into doDrawing

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 :: SDL.Window -> Universe -> IO Universe
-theUpdateStep = doSideEffects <=< updateRenderSplit
+theUpdateStep win = doSideEffects <=< updateRenderSplit win
 
-updateRenderSplit :: Universe -> IO Universe
+updateRenderSplit :: SDL.Window -> Universe -> IO Universe
-updateRenderSplit u = do
+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 ()

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
 

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

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 :: SDL.Window -> RenderData -> Universe -> IO ()
-doDrawing pdata u = do
+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 ()

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)

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'
+                worldAfterSimStep <- worldSideEffectsWindow startWorld'
-                glSwapWindow window
+--                glSwapWindow window
                 let updatedWorld = foldl' eventFn worldAfterSimStep es
                 performGC
                 endTicks <- ticks -- it might be better to use System.Clock (monotonic)