From f9a904d52bca72796f532feb4423a374c4b73906 Mon Sep 17 00:00:00 2001 From: justin Date: Sun, 3 Jul 2022 23:04:58 +0100 Subject: [PATCH] Make Shapes use Streaming rather than Vector streaming --- src/Dodge/Floor.hs | 2 +- src/Dodge/Item/Weapon/BatteryGuns.hs | 2 +- src/Dodge/Item/Weapon/BulletGun/Cane.hs | 2 +- src/Dodge/Item/Weapon/Shatter.hs | 2 +- src/Dodge/Item/Weapon/SprayGuns.hs | 2 +- src/Dodge/Render.hs | 30 ++++++++++++------------- src/Dodge/Render/ShapePicture.hs | 2 +- src/Shader/Poke.hs | 21 +++++++++-------- src/Shape.hs | 16 ++++++------- src/Shape/Data.hs | 7 +++--- src/ShapePicture.hs | 15 ++++++++----- 11 files changed, 54 insertions(+), 47 deletions(-) diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index ccb85a710..f6683000b 100644 --- a/src/Dodge/Floor.hs +++ b/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 ] diff --git a/src/Dodge/Item/Weapon/BatteryGuns.hs b/src/Dodge/Item/Weapon/BatteryGuns.hs index 37e83dab1..7db131418 100644 --- a/src/Dodge/Item/Weapon/BatteryGuns.hs +++ b/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 diff --git a/src/Dodge/Item/Weapon/BulletGun/Cane.hs b/src/Dodge/Item/Weapon/BulletGun/Cane.hs index 495b552f6..d74d60afe 100644 --- a/src/Dodge/Item/Weapon/BulletGun/Cane.hs +++ b/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) diff --git a/src/Dodge/Item/Weapon/Shatter.hs b/src/Dodge/Item/Weapon/Shatter.hs index 8a64b8e32..6d424b74d 100644 --- a/src/Dodge/Item/Weapon/Shatter.hs +++ b/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 diff --git a/src/Dodge/Item/Weapon/SprayGuns.hs b/src/Dodge/Item/Weapon/SprayGuns.hs index 7b70fe3f2..16f7cfa65 100644 --- a/src/Dodge/Item/Weapon/SprayGuns.hs +++ b/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 diff --git a/src/Dodge/Render.hs b/src/Dodge/Render.hs index 2da3dd364..b12767289 100644 --- a/src/Dodge/Render.hs +++ b/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) - ( 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) diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index c9b8830a4..7243a6895 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/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 #-} diff --git a/src/Shader/Poke.hs b/src/Shader/Poke.hs index b0287a7b5..534fe4bd5 100644 --- a/src/Shader/Poke.hs +++ b/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) - 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') diff --git a/src/Shape.hs b/src/Shape.hs index c453b21ce..dd0394328 100644 --- a/src/Shape.hs +++ b/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 #-} diff --git a/src/Shape/Data.hs b/src/Shape/Data.hs index 90529bace..97cf85fbf 100644 --- a/src/Shape/Data.hs +++ b/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 () diff --git a/src/ShapePicture.hs b/src/ShapePicture.hs index 925aa6971..d8a257b01 100644 --- a/src/ShapePicture.hs +++ b/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 - 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