Commit before attempting to stream worldSPic more effectively

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

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

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)
+worldSPic cfig w 
-    <> foldMap' (dbArg _prDraw) (filtOn _prPos _props)
+    =  ((mempty, extraPics cfig w)                                                  )
-    <> foldMap' (shiftDraw _blPos _blDir _blDraw) (filtOn _blPos _blocks)
+    <> (foldMap (dbArg _prDraw) (filtOn _prPos _props)                              )
-    <> foldMap' (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _shapes)
+    <> (foldMap (shiftDraw _blPos _blDir _blDraw) (filtOn _blPos _blocks)           )
-    <> foldMap' (dbArg _cpPict) (filtOn _cpPos _corpses)
+    <> (foldMap (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _shapes)   )
-    <> foldMap' (dbArg _crPict) (filtOn _crPos _creatures)
+    <> (foldMap (dbArg _cpPict) (filtOn _cpPos _corpses)                            )
-    <> foldMap' floorItemSPic (filtOn _flItPos _floorItems)
+    <> (foldMap (dbArg _crPict) (filtOn _crPos _creatures)                          )
-    <> foldMap' btSPic (filtOn _btPos _buttons)
+    <> (foldMap floorItemSPic (filtOn _flItPos _floorItems)                         )
-    <> foldMap' mcSPic (filtOn _mcPos _machines)
+    <> (foldMap btSPic (filtOn _btPos _buttons)                                     )
-    <> anyTargeting cfig w
+    <> (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 =
+debugDraw cfig w 
-    pic
+    | Show_debug `Set.member` _debug_booleans cfig =
-    <> 
+        pic
-    setLayer FixedCoordLayer (listPicturesAt (0.5*halfWidth cfig) 0 cfig $ map text ts)
+        <> 
+        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"

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

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

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

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)
+    wlcounts1 <- S.foldM_ (pokeW wlptr) (return 0) return (S.each wls)
-    wlcounts2 <- VS.foldM' (pokeW wiptr) 0 (VS.fromList wis)
+    wlcounts2 <- S.foldM_ (pokeW wiptr) (return 0) return (S.each wis)
-    flcounts  <- VS.foldM' (pokeF flptr) 0 (VS.fromList fls)
+    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 Float -> [(Point3,Point3)] -> IO Int
-pokePoint33s ptr = VS.foldlM' (pokePoint33 ptr) 0 . VS.fromList
+--pokePoint33s ptr = S.foldM_ (pokePoint33 ptr) (return 0) return . S.each
 
-pokePoint33 :: Ptr Float -> Int -> (Point3,Point3) -> IO Int
+--pokePoint33 :: Ptr Float -> Int -> (Point3,Point3) -> IO Int
-pokePoint33 ptr n (V3 a b c,V3 d e f) = do
+--pokePoint33 ptr n (V3 a b c,V3 d e f) = do
-    pokeElemOff ptr (off 0) a
+--    pokeElemOff ptr (off 0) a
-    pokeElemOff ptr (off 1) b
+--    pokeElemOff ptr (off 1) b
-    pokeElemOff ptr (off 2) c
+--    pokeElemOff ptr (off 2) c
-    pokeElemOff ptr (off 3) d
+--    pokeElemOff ptr (off 3) d
-    pokeElemOff ptr (off 4) e
+--    pokeElemOff ptr (off 4) e
-    pokeElemOff ptr (off 5) f
+--    pokeElemOff ptr (off 5) f
-    return (n+1)
+--    return (n+1)
-  where
+--  where
-    off i = n*6 + i
+--    off i = n*6 + i

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

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