From 673e9b11fcfe6c7795f98b1861572aa4a5b73a1b Mon Sep 17 00:00:00 2001 From: justin Date: Mon, 27 Jun 2022 17:47:03 +0100 Subject: [PATCH] Turn shapeObject's vertices into a stream --- src/Dodge/Data/ForegroundShape.hs | 2 +- src/Dodge/Floor.hs | 16 ++++++++-------- src/Dodge/Room/Foreground.hs | 10 +++++----- src/RandomHelp.hs | 3 ++- src/Shader/Poke.hs | 10 +++++++--- src/Shape.hs | 25 +++++++++++++------------ src/Shape/Data.hs | 19 +++++++++++-------- 7 files changed, 47 insertions(+), 38 deletions(-) diff --git a/src/Dodge/Data/ForegroundShape.hs b/src/Dodge/Data/ForegroundShape.hs index 622e82eca..9f25a4af9 100644 --- a/src/Dodge/Data/ForegroundShape.hs +++ b/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 diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 06e2725d8..1f1fc30a9 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -45,14 +45,14 @@ initialAnoTree = OnwardList , AnRoom slowDoorRoom -- , AnRoom $ roomCCrits 10 , AnTree firstBreather --- , AnTree $ telRoomLev 1 >>= rToOnward "telRoomLev" . pure . cleatOnward --- ] --- ---extraAnoList :: [Annotation] ---extraAnoList = ----- , (SpecificRoom . return . tToBTree $ treePost [corridor,corridor,cleatOnward corridor]) --- [ AnRoom $ roomCCrits 10 --- , AnRoom $ roomCCrits 10 + , AnTree $ telRoomLev 1 >>= rToOnward "telRoomLev" . pure . cleatOnward + ] + +extraAnoList :: [Annotation] +extraAnoList = +-- , (SpecificRoom . return . tToBTree $ treePost [corridor,corridor,cleatOnward corridor]) + [ AnRoom $ roomCCrits 10 + , AnRoom $ roomCCrits 10 , AnTree $ tToBTree "spawners" <$> spawnerRoom , AnRoom pistolerRoom , AnRoom doubleCorridorBarrels diff --git a/src/Dodge/Room/Foreground.hs b/src/Dodge/Room/Foreground.hs index 56655fa9b..6db8339d3 100644 --- a/src/Dodge/Room/Foreground.hs +++ b/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 = S.each . concatMap (map (stripZ . _svPos) . _shVs) +--shapePoints :: Shape -> Stream (Of Point2) Identity () +--shapePoints = S.each . concatMap (map (stripZ . _svPos) . _shVs) -shapeBounds :: Shape -> (Float,Float,Float,Float) -shapeBounds = fromMaybe (0,0,0,0) . boundPoints . shapePoints +--shapeBounds :: Shape -> (Float,Float,Float,Float) +--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) diff --git a/src/RandomHelp.hs b/src/RandomHelp.hs index d989650d2..aa0c508c5 100644 --- a/src/RandomHelp.hs +++ b/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] diff --git a/src/Shader/Poke.hs b/src/Shader/Poke.hs index b8d10e944..a04d76a07 100644 --- a/src/Shader/Poke.hs +++ b/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,21 +103,22 @@ 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 (memoTopPrismEdgeIndices V.! size) - return ( nv', nshapeindices', nedgeindices') + return (nv', nshapeindices', nedgeindices') 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 diff --git a/src/Shape.hs b/src/Shape.hs index 867ea2686..c453b21ce 100644 --- a/src/Shape.hs +++ b/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 -{-# INLINE overColSHM #-} -overColSHM = mapM . overColObjM +--overColSHM :: Monad m => (Point4 -> m Point4) -> Shape -> m Shape +--{-# INLINE overColSHM #-} +--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 -{-# INLINE overColObjM #-} -overColObjM f (ShapeObj st vs) = ShapeObj st <$> mapM (svCol f) vs +--overColObjM :: Monad m => (Point4 -> m Point4) -> ShapeObj -> m ShapeObj +--{-# INLINE overColObjM #-} +--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 #-} diff --git a/src/Shape/Data.hs b/src/Shape/Data.hs index 4fa49b469..01389eb50 100644 --- a/src/Shape/Data.hs +++ b/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] -{-# INLINE shVList #-} -shVList = _shVertices +--_shVertices :: Shape -> [ShapeV] +--{-# INLINE _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)