Make Shapes use Streaming rather than Vector streaming

src/Dodge/Floor.hs

@@ -42,8 +42,8 @@ initialAnoTree = OnwardList
         $ intersperse (AnTree corDoor)
     [ IntAnno $ AnTree . startRoom
     , AnRoom $ return airlock0
-    , AnRoom $ roomCCrits 10
     , AnRoom slowDoorRoom
+    , AnRoom $ roomCCrits 10
     , AnTree firstBreather
     , AnTree $ telRoomLev 1 >>= rToOnward "telRoomLev" . pure . cleatOnward
     ]

src/Dodge/Item/Weapon/BatteryGuns.hs

@@ -99,7 +99,7 @@ teslaGun = defaultBatteryGun
 teslaGunPic :: Item -> SPic
 teslaGunPic _ = noPic $ colorSH blue $
        upperPrismPoly 5 (rectNESW xb    8 xa    0)
-    ++ upperPrismPoly 5 (rectNESW (-xa) 8 (-xb) 0)
+    <> upperPrismPoly 5 (rectNESW (-xa) 8 (-xb) 0)
   where
     xa = 1
     xb = 9

src/Dodge/Item/Weapon/BulletGun/Cane.hs

@@ -302,7 +302,7 @@ miniGunXPict i spin _ =
     )
   where
     aBarrel = translateSH (V3 15 2 2) baseCaneShape
-    barrels = concatMap (\an -> aBarrel & rotateSHx (2*pi * fromIntegral an / fromIntegral i)) [1..i]
+    barrels = foldMap (\an -> aBarrel & rotateSHx (2*pi * fromIntegral an / fromIntegral i)) [1..i]
     a = fromIntegral spin / 100
     --x = fromIntegral am / 10
 --    clip y z = translateSH (V3 0 (-1) z) (rotateSHx (negate $ pi/4) 

src/Dodge/Item/Weapon/Shatter.hs

@@ -41,7 +41,7 @@ shatterGun = defaultWeapon
 shatterGunSPic :: Item -> SPic
 shatterGunSPic _ = noPic $ colorSH blue $
        upperPrismPoly 5 (rectNESW xb    8 xa    0)
-    ++ upperPrismPoly 5 (rectNESW (-xa) 8 (-xb) 0)
+    <> upperPrismPoly 5 (rectNESW (-xa) 8 (-xb) 0)
   where
     xa = 1
     xb = 9

src/Dodge/Item/Weapon/SprayGuns.hs

@@ -56,7 +56,7 @@ flamerPic :: Item -> SPic
 flamerPic it = 
     ( colorSH yellow $ 
         translateSHf tx ty (upperPrismPoly tz $ polyCirc 3 r)
-        ++ upperPrismPoly 5 (rectNESW 2 18 (-2) 0)
+        <> upperPrismPoly 5 (rectNESW 2 18 (-2) 0)
     , color black $ translate3 (V3 tx ty (tz+0.01)) $ circleSolid (r * am)
     )
   where

src/Dodge/Render.hs

@@ -51,21 +51,21 @@ doDrawing pdata u = do
     let (ws,wp) = wallSPics <> worldSPic cfig w
     ( (nWalls, nWins , nFls),(nShapeVs, nIndices, nSilIndices) )
         <- MP.bindM3 (\ _ wlwifl counts -> return (wlwifl,counts))
-        ( pokeBindFoldableLayer shadV layerCounts wp)
+            ( pokeBindFoldableLayer shadV layerCounts wp)
-        ( pokeWallsWindowsFloor
+            ( pokeWallsWindowsFloor
-            (shadVBOptr $ _wallTextureShader pdata) 
+                (shadVBOptr $ _wallTextureShader pdata) 
-            (shadVBOptr $ _windowShader pdata) 
+                (shadVBOptr $ _windowShader pdata) 
-            (shadVBOptr $ _textureArrayShader pdata)
+                (shadVBOptr $ _textureArrayShader pdata)
-            wallPointsCol
+                wallPointsCol
-            windowPoints
+                windowPoints
-            (_floorTiles w)
+                (_floorTiles w)
-        )
+            )
-        ( pokeShape
+            ( pokeShape
-            (_vboPtr $ _vaoVBO $ _shadVAO $ _shapeShader pdata)
+                (_vboPtr $ _vaoVBO $ _shadVAO $ _shapeShader pdata)
-            (_eboPtr $ _shapeEBO pdata)
+                (_eboPtr $ _shapeEBO pdata)
-            (_eboPtr $ _silhouetteEBO pdata)
+                (_eboPtr $ _silhouetteEBO pdata)
-            ws
+                ws
-        )
+            )
     -- bind wall points, silhouette data, surface geometry
     uncurry bindShaderBuffers $ unzip
         [ ( _wallTextureShader pdata, nWalls)

src/Dodge/Render/ShapePicture.hs

@@ -81,7 +81,7 @@ 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 #-}

src/Shader/Poke.hs

@@ -22,6 +22,8 @@ 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
+import qualified Streaming.Prelude as S
+import Streaming
 
 pokeVerxs 
     :: MV.MVector (PrimState IO) FullShader
@@ -50,9 +52,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 <- VS.foldM' (pokeW wlptr) 0 (VS.fromList wls)
-    wlcounts2 <- VS.foldM (pokeW wiptr) 0 (VS.fromList wis)
+    wlcounts2 <- VS.foldM' (pokeW wiptr) 0 (VS.fromList wis)
-    flcounts  <- VS.foldM (pokeF flptr) 0 (VS.fromList fls)
+    flcounts  <- VS.foldM' (pokeF flptr) 0 (VS.fromList fls)
     return (wlcounts1,wlcounts2,flcounts)
 
 pokeF :: Ptr Float -> Int -> (Point3,Point3) -> IO Int
@@ -80,9 +82,10 @@ pokeW ptr i' ((V2 a b,V2 c d),V4 e f g h) = do
     return $ i' + 1
 
 pokeShape :: Ptr Float -> Ptr GLushort -> Ptr GLushort 
-    -> [ShapeObj] 
+    -> Stream (Of ShapeObj) IO ()
     -> IO (Int,Int,Int)
-pokeShape ptr iptr ieptr = VS.foldM (pokeShapeObj ptr iptr ieptr) (0,0,0) . VS.fromList
+pokeShape ptr iptr ieptr = S.foldM_ (pokeShapeObj ptr iptr ieptr) (return (0,0,0)) return
+    
 
 pokeShapeObj
     :: Ptr Float 
@@ -98,14 +101,14 @@ pokeShapeObj ptr iptr ieptr counts (ShapeObj shType shVerts) = case shType of
 pokeTopPrism :: Int -> Ptr Float -> Ptr GLushort 
     -> Ptr GLushort 
     -> (Int,Int,Int)
-    -> VS.Stream IO ShapeV
+    -> Stream (Of ShapeV) IO ()
     -> IO (Int,Int,Int)
 --{-# INLINE pokeTopPrism #-}
 pokeTopPrism size ptr iptr ieptr (nv,nshapeindices,nedgeindices) svs = do
-    nv' <- VS.foldM (pokeJustV ptr) nv svs
+    nv' <- S.foldM_ (pokeJustV ptr) (return nv) return svs
-    nshapeindices' <- UV.foldM (pokeTopPrismIndex nv iptr) nshapeindices 
+    nshapeindices' <- UV.foldM' (pokeTopPrismIndex nv iptr) nshapeindices 
         (memoTopPrismIndices     V.! size)
-    nedgeindices' <- UV.foldM (pokeTopPrismEdgeIndex nv ieptr) nedgeindices
+    nedgeindices' <- UV.foldM' (pokeTopPrismEdgeIndex nv ieptr) nedgeindices
         (memoTopPrismEdgeIndices V.! size)
     return (nv', nshapeindices', nedgeindices')
 

src/Shape.hs

@@ -21,7 +21,7 @@ module Shape
 import Geometry
 import Shape.Data
 import Color
-import qualified Data.Vector.Fusion.Stream.Monadic as VS
+import qualified Streaming.Prelude as S
 
 emptySH :: Shape
 {-# INLINE emptySH #-}
@@ -45,7 +45,7 @@ prismPoly
     -> [Point3] 
     -> Shape
 {-# INLINE prismPoly #-}
-prismPoly upps downps = [ShapeObj (TopPrism n) (VS.fromList $ f upps downps)]
+prismPoly upps downps = S.yield (ShapeObj (TopPrism n) (S.each $ f upps downps))
   where
     n = length upps
     f (a:as) (b:bs) = g a:g b:f as bs
@@ -58,7 +58,7 @@ upperPrismPoly
     -> [Point2] 
     -> Shape
 {-# INLINE upperPrismPoly #-}
-upperPrismPoly h ps = [ShapeObj (TopPrism n) (VS.fromList $ f ps)]
+upperPrismPoly h ps = S.yield (ShapeObj (TopPrism n) (S.each $ f ps))
   where
     n = length ps
     g h' (V2 x y) = pairToSV (V3 x y h', black)
@@ -70,7 +70,7 @@ upperPrismPolyHalf
     -> [Point2] 
     -> Shape
 {-# INLINE upperPrismPolyHalf #-}
-upperPrismPolyHalf h ps = [ShapeObj (TopPrism n) (VS.fromList $ f upps downps)]
+upperPrismPolyHalf h ps = S.yield (ShapeObj (TopPrism n) (S.each $ f upps downps))
   where
     n = length ps
     upps = map f' ps
@@ -86,7 +86,7 @@ colorSH = overColSH . const
 
 overColSH :: (Point4 -> Point4) -> Shape -> Shape
 {-# INLINE overColSH #-}
-overColSH = fmap . overColObj
+overColSH = S.map . overColObj
 
 --overColSHM :: Monad m => (Point4 -> m Point4) -> Shape -> m Shape
 --{-# INLINE overColSHM #-}
@@ -94,7 +94,7 @@ overColSH = fmap . overColObj
 
 overPosSHI :: (Point3 -> Point3) -> Shape -> Shape
 {-# INLINE overPosSHI #-}
-overPosSHI = fmap . overPosObj
+overPosSHI = S.map . overPosObj
 
 translateSH :: Point3 -> Shape -> Shape
 {-# INLINE translateSH #-}
@@ -126,7 +126,7 @@ scaleSH (V3 a b c) = overPosSHI (\(V3 x y z) -> V3 (x*a) (y*b) (z*c))
 
 overColObj :: (Point4 -> Point4) -> ShapeObj -> ShapeObj
 {-# INLINE overColObj #-}
-overColObj f (ShapeObj st vs) = ShapeObj st (VS.map (overColVertex f) vs)
+overColObj f (ShapeObj st vs) = ShapeObj st (S.map (overColVertex f) vs)
 
 --overColObjM :: Monad m => (Point4 -> m Point4) -> ShapeObj -> m ShapeObj
 --{-# INLINE overColObjM #-}
@@ -138,7 +138,7 @@ overColVertex f (ShapeV a b) = ShapeV a (f b)
 
 overPosObj :: (Point3 -> Point3) -> ShapeObj -> ShapeObj
 {-# INLINE overPosObj #-}
-overPosObj f (ShapeObj st vs) = ShapeObj st $ VS.map (overPosVertex f) vs
+overPosObj f (ShapeObj st vs) = ShapeObj st $ S.map (overPosVertex f) vs
 
 overPosVertex :: (Point3 -> Point3) -> ShapeV -> ShapeV
 {-# INLINE overPosVertex #-}

src/Shape/Data.hs

@@ -7,10 +7,11 @@ module Shape.Data
     where
 import Geometry.Data
 
-import qualified Data.Vector.Fusion.Stream.Monadic as VS
+--import qualified Data.Vector.Fusion.Stream.Monadic as VS
 --import Data.Vector.Fusion.Util
 import Control.Lens
-type Shape = [ShapeObj]
+import Streaming
+type Shape = Stream (Of ShapeObj) IO ()
 
 --_shVertices :: Shape -> [ShapeV]
 --{-# INLINE _shVertices #-}
@@ -30,7 +31,7 @@ shEfromList = id
 
 data ShapeObj = ShapeObj 
     { _shType :: ShapeType 
-    , _shVs :: VS.Stream IO ShapeV
+    , _shVs :: Stream (Of ShapeV) IO ()
     }
   deriving ()
 

src/ShapePicture.hs

@@ -49,11 +49,14 @@ rotateSP :: Float -> SPic -> SPic
 rotateSP a = bimap (rotateSH a) (rotate a)
 
 mirrorSPxz :: SPic -> SPic
-mirrorSPxz = bimap (reverse . overPosSH flipy) mirrorxz
+mirrorSPxz = bimap id mirrorxz
-  where
+--mirrorSPxz = bimap (reverse . overPosSH flipy) mirrorxz
-    flipy (V3 x y z) = V3 x (negate y) z
+--  where
+--    flipy (V3 x y z) = V3 x (negate y) z
 
 mirrorSPyz :: SPic -> SPic
-mirrorSPyz = bimap (reverse . overPosSH flipx) mirroryz
+mirrorSPyz = bimap id mirroryz
-  where
+-- this can be done by creating a reverse topprism ShapeObj
-    flipx (V3 x y z) = V3 (negate x) y z
+--mirrorSPyz = bimap (reverse . overPosSH flipx) mirroryz
+--  where
+--    flipx (V3 x y z) = V3 (negate x) y z