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

Make Shapes use Streaming rather than Vector streaming

Browse Source
This commit is contained in:
justin
2022-07-03 23:04:58 +01:00
parent 02fcb5f072
commit f9a904d52b
11 changed files with 54 additions and 47 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Floor.hs
+1 -1
View File
@@ -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
+1 -1
View File
@@ -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
+1 -1
View File
@@ -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
+1 -1
View File
@@ -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
+1 -1
View File
@@ -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
+15 -15
View File
@@ -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)
( pokeWallsWindowsFloor
(shadVBOptr $ _wallTextureShader pdata)
(shadVBOptr $ _windowShader pdata)
(shadVBOptr $ _textureArrayShader pdata)
wallPointsCol
windowPoints
(_floorTiles w)
)
( pokeShape
(_vboPtr $ _vaoVBO $ _shadVAO $ _shapeShader pdata)
(_eboPtr $ _shapeEBO pdata)
(_eboPtr $ _silhouetteEBO pdata)
ws
)
( pokeBindFoldableLayer shadV layerCounts wp)
( pokeWallsWindowsFloor
(shadVBOptr $ _wallTextureShader pdata)
(shadVBOptr $ _windowShader pdata)
(shadVBOptr $ _textureArrayShader pdata)
wallPointsCol
windowPoints
(_floorTiles w)
)
( pokeShape
(_vboPtr $ _vaoVBO $ _shadVAO $ _shapeShader pdata)
(_eboPtr $ _shapeEBO pdata)
(_eboPtr $ _silhouetteEBO pdata)
ws
)
-- bind wall points, silhouette data, surface geometry
uncurry bindShaderBuffers $ unzip
[ ( _wallTextureShader pdata, nWalls)
src/Dodge/Render/ShapePicture.hs
+1 -1
View File
@@ -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
+12 -9
View File
@@ -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)
wlcounts2 <- VS.foldM (pokeW wiptr) 0 (VS.fromList wis)
flcounts <- VS.foldM (pokeF flptr) 0 (VS.fromList fls)
wlcounts1 <- VS.foldM' (pokeW wlptr) 0 (VS.fromList wls)
wlcounts2 <- VS.foldM' (pokeW wiptr) 0 (VS.fromList wis)
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
nshapeindices' <- UV.foldM (pokeTopPrismIndex nv iptr) nshapeindices
nv' <- S.foldM_ (pokeJustV ptr) (return nv) return svs
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
+8 -8
View File
@@ -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
+4 -3
View File
@@ -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
+9 -6
View File
@@ -49,11 +49,14 @@ rotateSP :: Float -> SPic -> SPic
rotateSP a = bimap (rotateSH a) (rotate a)
mirrorSPxz :: SPic -> SPic
mirrorSPxz = bimap (reverse . overPosSH flipy) mirrorxz
where
flipy (V3 x y z) = V3 x (negate y) z
mirrorSPxz = bimap id mirrorxz
--mirrorSPxz = bimap (reverse . overPosSH flipy) mirrorxz
-- where
-- flipy (V3 x y z) = V3 x (negate y) z
mirrorSPyz :: SPic -> SPic
mirrorSPyz = bimap (reverse . overPosSH flipx) mirroryz
where
flipx (V3 x y z) = V3 (negate x) y z
mirrorSPyz = bimap id mirroryz
-- this can be done by creating a reverse topprism ShapeObj
--mirrorSPyz = bimap (reverse . overPosSH flipx) mirroryz
-- where
-- flipx (V3 x y z) = V3 (negate x) y z