Turn shapeObject's vertices into a stream

src/Dodge/Data/ForegroundShape.hs

@@ -12,5 +12,5 @@ data ForegroundShape = ForegroundShape
     , _fsRad :: Float  -- This should probably be a bounding box
     , _fsSPic :: SPic
     }
-  deriving (Eq,Show,Ord)
+  deriving ()
 makeLenses ''ForegroundShape

src/Dodge/Floor.hs

@@ -45,14 +45,14 @@ initialAnoTree = OnwardList
     , AnRoom slowDoorRoom
 --    , AnRoom $ roomCCrits 10
     , AnTree firstBreather
---    , AnTree $ telRoomLev 1 >>= rToOnward "telRoomLev" . pure . cleatOnward
+    , AnTree $ telRoomLev 1 >>= rToOnward "telRoomLev" . pure . cleatOnward
---    ]
+    ]
---
+
---extraAnoList :: [Annotation]
+extraAnoList :: [Annotation]
---extraAnoList =
+extraAnoList =
-----     ,  (SpecificRoom . return . tToBTree $ treePost [corridor,corridor,cleatOnward corridor])
+--     ,  (SpecificRoom . return . tToBTree $ treePost [corridor,corridor,cleatOnward corridor])
---    [ AnRoom $ roomCCrits 10
+    [ AnRoom $ roomCCrits 10
---    , AnRoom $ roomCCrits 10
+    , AnRoom $ roomCCrits 10
     , AnTree $ tToBTree "spawners" <$> spawnerRoom
     , AnRoom pistolerRoom
     , AnRoom doubleCorridorBarrels

src/Dodge/Room/Foreground.hs

@@ -125,14 +125,14 @@ putShape sh = PutForeground $ defaultForeground
     & fsRad .~ radBounds bnds
     & fsSPic .~ noPic (uncurryV translateSHf (-m) $ sh)
   where
-    bnds = shapeBounds sh
+    bnds = (0,0,0,0) -- shapeBounds sh
     m = midBounds bnds
 
-shapePoints :: Shape -> Stream (Of Point2) Identity ()
+--shapePoints :: Shape -> Stream (Of Point2) Identity ()
-shapePoints = S.each . concatMap (map (stripZ . _svPos) . _shVs)
+--shapePoints = S.each . concatMap (map (stripZ . _svPos) . _shVs)
 
-shapeBounds :: Shape -> (Float,Float,Float,Float)
+--shapeBounds :: Shape -> (Float,Float,Float,Float)
-shapeBounds = fromMaybe (0,0,0,0) . boundPoints . shapePoints
+--shapeBounds = fromMaybe (0,0,0,0) . boundPoints . shapePoints
 
 midBounds :: (Float,Float,Float,Float) -> Point2
 midBounds (n,s,e,w) = V2 ((n + s)/2) ((e + w)/2)

src/RandomHelp.hs

@@ -5,6 +5,7 @@ module RandomHelp
     , module RandomHelp
     ) where
 import Geometry
+import StrictHelp
 
 import System.Random
 import Control.Monad.State
@@ -48,7 +49,7 @@ shuffle xs = do
     let f ys rand = let (as,b:bs) = splitAt rand ys
                     in  (as ++ bs, b)
     let (_,zs) = mapAccumR f xs rands
-    return zs
+    return $ forceElements zs `seq` zs
 
 -- | Randomly shuffle the tail of a list, not safe.
 shuffleTail :: RandomGen g => [a] -> State g [a]

src/Shader/Poke.hs

@@ -19,6 +19,7 @@ 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
 
@@ -102,11 +103,11 @@ pokeShapeObj ptr iptr ieptr counts (ShapeObj shType shVerts) = case shType of
 pokeTopPrism :: Int -> Ptr Float -> Ptr GLushort 
     -> Ptr GLushort 
     -> (Int,Int,Int)
-    -> [ShapeV] 
+    -> VS.Stream IO ShapeV
     -> IO (Int,Int,Int)
 {-# INLINE pokeTopPrism #-}
 pokeTopPrism size ptr iptr ieptr (nv,nshapeindices,nedgeindices) svs = do
-    nv' <- VS.foldM (pokeJustV ptr)  nv                (VS.fromList svs)                 
+    nv' <- VS.foldM (pokeJustV ptr) nv svs
     nshapeindices' <- UV.foldM (pokeTopPrismIndex nv iptr) nshapeindices 
         (memoTopPrismIndices     V.! size)
     nedgeindices' <- UV.foldM (pokeTopPrismEdgeIndex nv ieptr) nedgeindices
@@ -117,6 +118,7 @@ pokeTopPrismEdgeIndex :: Int -> Ptr GLushort
     -> Int
     -> Int 
     -> IO Int
+{-# INLINE pokeTopPrismEdgeIndex #-}
 pokeTopPrismEdgeIndex nv eiptr nedgeindices ioff = do
     pokeElemOff eiptr nedgeindices (fromIntegral $ nv + ioff)
     return $ nedgeindices + 1
@@ -125,6 +127,7 @@ pokeTopPrismIndex :: Int -> Ptr GLushort
     -> Int
     -> Int 
     -> IO Int
+{-# INLINE pokeTopPrismIndex #-}
 pokeTopPrismIndex nv iptr nshapeindices ioff = do
     pokeElemOff iptr nshapeindices (fromIntegral $ nv + ioff)
     return $ nshapeindices + 1
@@ -165,6 +168,7 @@ pokeJustV :: Ptr Float
     -> Int
     -> ShapeV 
     -> IO Int
+{-# INLINE pokeJustV #-}
 pokeJustV ptr nv sh = do
     let off i = nv*7 + i
     pokeElemOff ptr (off 0) a

src/Shape.hs

@@ -15,12 +15,13 @@ module Shape
     , scaleSH
     , colorSH
     , overColSH
-    , overColSHM
+--    , overColSHM
     , overPosSH
     ) where
 import Geometry
 import Shape.Data
 import Color
+import qualified Data.Vector.Fusion.Stream.Monadic as VS
 
 emptySH :: Shape
 {-# INLINE emptySH #-}
@@ -44,7 +45,7 @@ prismPoly
     -> [Point3] 
     -> Shape
 {-# INLINE prismPoly #-}
-prismPoly upps downps = [ShapeObj (TopPrism n) (f upps downps)]
+prismPoly upps downps = [ShapeObj (TopPrism n) (VS.fromList $ f upps downps)]
   where
     n = length upps
     f (a:as) (b:bs) = g a:g b:f as bs
@@ -57,7 +58,7 @@ upperPrismPoly
     -> [Point2] 
     -> Shape
 {-# INLINE upperPrismPoly #-}
-upperPrismPoly h ps = [ShapeObj (TopPrism n) (f ps)]
+upperPrismPoly h ps = [ShapeObj (TopPrism n) (VS.fromList $ f ps)]
   where
     n = length ps
     g h' (V2 x y) = pairToSV (V3 x y h', black)
@@ -69,7 +70,7 @@ upperPrismPolyHalf
     -> [Point2] 
     -> Shape
 {-# INLINE upperPrismPolyHalf #-}
-upperPrismPolyHalf h ps = [ShapeObj (TopPrism n) (f upps downps)]
+upperPrismPolyHalf h ps = [ShapeObj (TopPrism n) (VS.fromList $ f upps downps)]
   where
     n = length ps
     upps = map f' ps
@@ -87,9 +88,9 @@ overColSH :: (Point4 -> Point4) -> Shape -> Shape
 {-# INLINE overColSH #-}
 overColSH = fmap . overColObj
 
-overColSHM :: Monad m => (Point4 -> m Point4) -> Shape -> m Shape
+--overColSHM :: Monad m => (Point4 -> m Point4) -> Shape -> m Shape
-{-# INLINE overColSHM #-}
+--{-# INLINE overColSHM #-}
-overColSHM = mapM . overColObjM
+--overColSHM = mapM . overColObjM
 
 overPosSHI :: (Point3 -> Point3) -> Shape -> Shape
 {-# INLINE overPosSHI #-}
@@ -125,11 +126,11 @@ 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 (map (overColVertex f) vs)
+overColObj f (ShapeObj st vs) = ShapeObj st (VS.map (overColVertex f) vs)
 
-overColObjM :: Monad m => (Point4 -> m Point4) -> ShapeObj -> m ShapeObj
+--overColObjM :: Monad m => (Point4 -> m Point4) -> ShapeObj -> m ShapeObj
-{-# INLINE overColObjM #-}
+--{-# INLINE overColObjM #-}
-overColObjM f (ShapeObj st vs) = ShapeObj st <$> mapM (svCol f) vs
+--overColObjM f (ShapeObj st vs) = ShapeObj st <$> mapM (svCol f) vs
 
 overColVertex :: (Point4 -> Point4) -> ShapeV -> ShapeV
 {-# INLINE overColVertex #-}
@@ -137,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 $ map (overPosVertex f) vs
+overPosObj f (ShapeObj st vs) = ShapeObj st $ VS.map (overPosVertex f) vs
 
 overPosVertex :: (Point3 -> Point3) -> ShapeV -> ShapeV
 {-# INLINE overPosVertex #-}

src/Shape/Data.hs

@@ -7,15 +7,18 @@ module Shape.Data
     where
 import Geometry.Data
 
+import qualified Data.Vector.Fusion.Stream.Monadic as VS
+import Data.Vector.Fusion.Util
 import Control.Lens
 type Shape = [ShapeObj]
-_shVertices :: Shape -> [ShapeV]
-{-# INLINE _shVertices #-}
-_shVertices = concatMap _shVs
 
-shVList :: Shape -> [ShapeV]
+--_shVertices :: Shape -> [ShapeV]
-{-# INLINE shVList #-}
+--{-# INLINE _shVertices #-}
-shVList = _shVertices
+--_shVertices = concatMap _shVs
+
+--shVList :: Shape -> [ShapeV]
+--{-# INLINE shVList #-}
+--shVList = _shVertices
 --shVList = DL.toList . _shVertices
 
 {-# INLINE shVfromList #-}
@@ -27,9 +30,9 @@ shEfromList = id
 
 data ShapeObj = ShapeObj 
     { _shType :: ShapeType 
-    , _shVs :: [ShapeV]
+    , _shVs :: VS.Stream IO ShapeV
     }
-  deriving (Eq,Ord,Show)
+  deriving ()
 
 newtype ShapeType = TopPrism Int
   deriving (Eq,Ord,Show)