justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Turn shapeObject's vertices into a stream

Browse Source
This commit is contained in:
justin
2022-06-27 17:47:03 +01:00
parent 8d5800d806
commit 673e9b11fc
7 changed files with 47 additions and 38 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data/ForegroundShape.hs
+1 -1
View File
@@ -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
+8 -8
View File
@@ -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
src/Dodge/Room/Foreground.hs
+5 -5
View File
@@ -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)
src/RandomHelp.hs
+2 -1
View File
@@ -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
+7 -3
View File
@@ -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
src/Shape.hs
+13 -12
View File
@@ -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 #-}
src/Shape/Data.hs
+11 -8
View File
@@ -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)