From 1e32b054063ea792dadb28bc4e9b95b53ca56fc8 Mon Sep 17 00:00:00 2001 From: justin Date: Mon, 4 Jul 2022 11:04:09 +0100 Subject: [PATCH] Commit before attempting to stream worldSPic more effectively --- src/Dodge/Config/Data.hs | 1 + src/Dodge/Default/World.hs | 1 - src/Dodge/Render/ShapePicture.hs | 40 +++++++++++++++++++------------- src/Picture/Data.hs | 1 - src/Render.hs | 4 ++-- src/Shader/Bind.hs | 6 +++-- src/Shader/Poke.hs | 35 ++++++++++++++-------------- src/Shape/Data.hs | 1 - src/Sound.hs | 6 ++--- 9 files changed, 51 insertions(+), 44 deletions(-) diff --git a/src/Dodge/Config/Data.hs b/src/Dodge/Config/Data.hs index d4b8534eb..456d5c109 100644 --- a/src/Dodge/Config/Data.hs +++ b/src/Dodge/Config/Data.hs @@ -29,6 +29,7 @@ data Configuration = Configuration deriving (Generic, Show) data DebugBool = Show_ms_frame + | Show_debug | Show_sound | Noclip | Cr_status diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs index 0b05dad37..b91f25237 100644 --- a/src/Dodge/Default/World.hs +++ b/src/Dodge/Default/World.hs @@ -20,7 +20,6 @@ import qualified Data.Map as M import qualified Data.Set as S import Data.Graph.Inductive.Graph hiding ((&)) --import Data.Graph.Inductive.NodeMap ---import qualified Data.Vector.Fusion.Stream.Monadic as VS defaultWorld :: World defaultWorld = World { _keys = S.empty diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index 808bf0549..3abc49297 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/src/Dodge/Render/ShapePicture.hs @@ -26,6 +26,7 @@ import Picture import Sound.Data import Geometry.ConvexPoly import ShortShow +import Shape.Data --import Dodge.Base.Collide --import Data.Foldable @@ -35,27 +36,31 @@ import qualified Data.Map.Strict as M import Control.Lens import Data.Maybe import qualified Streaming.Prelude as S +import Streaming import qualified Data.Graph.Inductive as FGL import qualified Data.Set as Set import Padding -import Data.Foldable +--import Data.Foldable -- TODO only filter out shapes outside the range of the furthest shown light source worldSPic :: Configuration -> World -> SPic -worldSPic cfig w = (mempty, extraPics cfig w) - <> foldMap' (dbArg _prDraw) (filtOn _prPos _props) - <> foldMap' (shiftDraw _blPos _blDir _blDraw) (filtOn _blPos _blocks) - <> foldMap' (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _shapes) - <> foldMap' (dbArg _cpPict) (filtOn _cpPos _corpses) - <> foldMap' (dbArg _crPict) (filtOn _crPos _creatures) - <> foldMap' floorItemSPic (filtOn _flItPos _floorItems) - <> foldMap' btSPic (filtOn _btPos _buttons) - <> foldMap' mcSPic (filtOn _mcPos _machines) - <> anyTargeting cfig w +worldSPic cfig w + = ((mempty, extraPics cfig w) ) + <> (foldMap (dbArg _prDraw) (filtOn _prPos _props) ) + <> (foldMap (shiftDraw _blPos _blDir _blDraw) (filtOn _blPos _blocks) ) + <> (foldMap (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _shapes) ) + <> (foldMap (dbArg _cpPict) (filtOn _cpPos _corpses) ) + <> (foldMap (dbArg _crPict) (filtOn _crPos _creatures) ) + <> (foldMap floorItemSPic (filtOn _flItPos _floorItems) ) + <> (foldMap btSPic (filtOn _btPos _buttons) ) + <> (foldMap mcSPic (filtOn _mcPos _machines) ) + <> (anyTargeting cfig w ) where filtOn f g = IM.filter (pointIsClose . f) (g w) pointIsClose = cullPoint cfig w +type SPicStream = Stream (Of ShapeObj) (Stream (Of Verx) IO) () + anyTargeting :: Configuration -> World -> SPic anyTargeting cfig w = (mempty,pictures $ IM.elems $ IM.mapMaybe f $ _crInv cr) where @@ -82,20 +87,23 @@ extraPics cfig w = pictures (_decorations w) <> concatMapPic clDraw (_clouds w ) <> concatMapPic ppDraw (_pressPlates w ) <> viewClipBounds cfig w --- <> debugDraw cfig w + <> debugDraw cfig w debugDraw :: Configuration -> World -> Picture {-# INLINE debugDraw #-} -debugDraw cfig w = - pic - <> - setLayer FixedCoordLayer (listPicturesAt (0.5*halfWidth cfig) 0 cfig $ map text ts) +debugDraw cfig w + | Show_debug `Set.member` _debug_booleans cfig = + pic + <> + setLayer FixedCoordLayer (listPicturesAt (0.5*halfWidth cfig) 0 cfig $ map text ts) + | otherwise = mempty where (ts, pic) = foldMap (debugDraw' cfig w) (_debug_booleans cfig) debugDraw' :: Configuration -> World -> DebugBool -> ([String],Picture) {-# INLINE debugDraw' #-} debugDraw' cfig w bl = case bl of + Show_debug -> lstring "Show debug" Noclip -> lstring "Noclip" Remove_LOS -> lstring "No line of sight" Cull_more_lights -> lstring "Cull more lights" diff --git a/src/Picture/Data.hs b/src/Picture/Data.hs index 2bdaac932..f77177cfb 100644 --- a/src/Picture/Data.hs +++ b/src/Picture/Data.hs @@ -4,7 +4,6 @@ module Picture.Data where import Geometry.Data ---import qualified Data.Vector.Fusion.Stream.Monadic as VS import Control.Lens import Streaming data Verx = Verx diff --git a/src/Render.hs b/src/Render.hs index 3815e09ae..c09b0b2d1 100644 --- a/src/Render.hs +++ b/src/Render.hs @@ -19,9 +19,9 @@ import Graphics.Rendering.OpenGL hiding (Line,translate,scale,imageHeight,Polygo import qualified Data.Vector.Unboxed.Mutable as UMV import qualified Data.Vector.Mutable as MV import Control.Monad.Primitive -import qualified Data.Vector.Fusion.Stream.Monadic as VS import Graphics.GL.Core43 import Control.Monad +import qualified Streaming.Prelude as S divideSize :: Int -> Size -> Size divideSize i (Size x y) = Size (div x $ fromIntegral i) (div y $ fromIntegral i) @@ -53,7 +53,7 @@ createLightMap pdata lightPoints nWalls nSils nCaps drawObjShads toPos = do -- to consider: adding normals/a "material" for each fragment blendFunc $= (Zero, OneMinusSrcColor) stencilTest $= Enabled - flip VS.mapM_ (VS.fromList lightPoints) $ \(V3 x y z,rad,V3 r g b) -> do + flip S.mapM_ (S.each lightPoints) $ \(V3 x y z,rad,V3 r g b) -> do depthFunc $= Just Less -- setup stencil colorMask $= Color4 Disabled Disabled Disabled Disabled diff --git a/src/Shader/Bind.hs b/src/Shader/Bind.hs index 88a6bbc5c..a80597f13 100644 --- a/src/Shader/Bind.hs +++ b/src/Shader/Bind.hs @@ -10,9 +10,9 @@ import Graphics.Rendering.OpenGL hiding (Line,translate,scale,imageHeight,Polygo import Foreign hiding (rotate) import qualified Data.Vector.Unboxed.Mutable as UMV import qualified Data.Vector.Mutable as MV -import qualified Data.Vector.Fusion.Stream.Monadic as VS import Control.Monad.Primitive import Control.Monad +import qualified Streaming.Prelude as S bindArrayBuffers :: Int -> VBO -> IO () {-# INLINABLE bindArrayBuffers #-} @@ -32,7 +32,9 @@ bindShaderLayers shads counts = MV.imapM_ f shads let theVBO = _vaoVBO $ _shadVAO shad stride = sum $ _vboAttribSizes theVBO bindBuffer ArrayBuffer $= (Just . _vbo $ theVBO) - VS.mapM_ (g stride theVBO) $ VS.enumFromStepN 0 1 6 -- [0..5] + --VS.mapM_ (g stride theVBO) $ VS.enumFromStepN 0 1 6 -- [0..5] + S.mapM_ (g stride theVBO) $ S.each [0..5] + where g stride theVBO lay = do numVs <- UMV.unsafeRead counts $ lay * 6 + i diff --git a/src/Shader/Poke.hs b/src/Shader/Poke.hs index bebeb94e9..4c4727980 100644 --- a/src/Shader/Poke.hs +++ b/src/Shader/Poke.hs @@ -2,7 +2,7 @@ module Shader.Poke ( pokeVerxs , pokeLayVerxs , pokeArrayOff - , pokePoint33s +-- , pokePoint33s , pokeShape , pokeWallsWindowsFloor ) where @@ -18,7 +18,6 @@ import qualified Data.Vector as V import qualified Data.Vector.Unboxed as UV import qualified Data.Vector.Unboxed.Mutable as UMV import qualified Data.Vector.Mutable as MV -import qualified Data.Vector.Fusion.Stream.Monadic as VS --import Data.Vector.Fusion.Util import Control.Monad.Primitive --import qualified Control.Monad.Parallel as MP @@ -52,9 +51,9 @@ pokeWallsWindowsFloor -> [ ( Point3 , Point3 ) ] -> IO (Int,Int,Int) pokeWallsWindowsFloor wlptr wiptr flptr wls wis fls = do - wlcounts1 <- VS.foldM' (pokeW wlptr) 0 (VS.fromList wls) - wlcounts2 <- VS.foldM' (pokeW wiptr) 0 (VS.fromList wis) - flcounts <- VS.foldM' (pokeF flptr) 0 (VS.fromList fls) + wlcounts1 <- S.foldM_ (pokeW wlptr) (return 0) return (S.each wls) + wlcounts2 <- S.foldM_ (pokeW wiptr) (return 0) return (S.each wis) + flcounts <- S.foldM_ (pokeF flptr) (return 0) return (S.each fls) return (wlcounts1,wlcounts2,flcounts) pokeF :: Ptr Float -> Int -> (Point3,Point3) -> IO Int @@ -232,17 +231,17 @@ pokeArrayOff :: Ptr Float -> Int -> [Float] -> IO () {-# INLINE pokeArrayOff #-} pokeArrayOff ptr i = pokeArray (plusPtr ptr (floatSize * i)) -pokePoint33s :: Ptr Float -> [(Point3,Point3)] -> IO Int -pokePoint33s ptr = VS.foldlM' (pokePoint33 ptr) 0 . VS.fromList +--pokePoint33s :: Ptr Float -> [(Point3,Point3)] -> IO Int +--pokePoint33s ptr = S.foldM_ (pokePoint33 ptr) (return 0) return . S.each -pokePoint33 :: Ptr Float -> Int -> (Point3,Point3) -> IO Int -pokePoint33 ptr n (V3 a b c,V3 d e f) = do - pokeElemOff ptr (off 0) a - pokeElemOff ptr (off 1) b - pokeElemOff ptr (off 2) c - pokeElemOff ptr (off 3) d - pokeElemOff ptr (off 4) e - pokeElemOff ptr (off 5) f - return (n+1) - where - off i = n*6 + i +--pokePoint33 :: Ptr Float -> Int -> (Point3,Point3) -> IO Int +--pokePoint33 ptr n (V3 a b c,V3 d e f) = do +-- pokeElemOff ptr (off 0) a +-- pokeElemOff ptr (off 1) b +-- pokeElemOff ptr (off 2) c +-- pokeElemOff ptr (off 3) d +-- pokeElemOff ptr (off 4) e +-- pokeElemOff ptr (off 5) f +-- return (n+1) +-- where +-- off i = n*6 + i diff --git a/src/Shape/Data.hs b/src/Shape/Data.hs index 97cf85fbf..629073e68 100644 --- a/src/Shape/Data.hs +++ b/src/Shape/Data.hs @@ -7,7 +7,6 @@ module Shape.Data where import Geometry.Data ---import qualified Data.Vector.Fusion.Stream.Monadic as VS --import Data.Vector.Fusion.Util import Control.Lens import Streaming diff --git a/src/Sound.hs b/src/Sound.hs index 86c2a3623..358e9ddc4 100644 --- a/src/Sound.hs +++ b/src/Sound.hs @@ -26,7 +26,7 @@ import qualified SDL.Mixer as Mix import Data.Maybe import qualified Data.IntMap.Strict as IM import qualified Data.Map as M -import qualified Data.Vector.Fusion.Stream.Monadic as VS +import qualified Streaming.Prelude as S import Control.Monad import Control.Monad.Trans import Control.Monad.Trans.Maybe @@ -140,9 +140,9 @@ playIfFree c times = do As for 'playSoundQueue', but with positional information in the form of an Int16. -} playPositionalSoundQueue :: IM.IntMap Mix.Chunk -> [(Int,Int16)] -> IO () playPositionalSoundQueue chunkMap - = VS.mapM_ ( \(n,a) -> + = S.mapM_ ( \(n,a) -> runMaybeT $ playIfFree (chunkMap IM.! n) Mix.Once >>= setChannelPos a ) - . VS.fromList + . S.each setChannelPos :: Int16 -> Mix.Channel -> MaybeT IO Mix.Channel setChannelPos a i = do