From 8b72df27720193f66cdc117529b537215a8df73e Mon Sep 17 00:00:00 2001 From: justin Date: Mon, 27 Jun 2022 15:33:24 +0100 Subject: [PATCH] Change poke to use folding rather than store incremental ints in vector --- src/Dodge/Data.hs | 4 -- src/Dodge/Default/World.hs | 1 - src/Dodge/Floor.hs | 18 +++---- src/Dodge/Layout.hs | 34 ------------- src/Dodge/Placement/PlaceSpot.hs | 12 ----- src/Dodge/Render/ShapePicture.hs | 6 +-- src/Dodge/Room/Foreground.hs | 7 ++- src/Dodge/Room/Modify/Girder.hs | 6 +-- src/Shader/Poke.hs | 83 ++++++++++++++++++++++++-------- 9 files changed, 78 insertions(+), 93 deletions(-) diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 0c35ef4cd..ee3970db0 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -61,7 +61,6 @@ import Geometry.ConvexPoly import Sound.Data import Dodge.GameRoom import Color -import Shape import Data.Tile import MaybeHelp @@ -141,7 +140,6 @@ data World = World , _playingSounds :: M.Map SoundOrigin Sound , _decorations :: IM.IntMap Picture , _shapes :: IM.IntMap ForegroundShape - , _foregroundShape :: Shape , _corpses :: IM.IntMap Corpse , _clickMousePos :: Point2 , _pathGraph :: Gr Point2 Float @@ -1402,10 +1400,8 @@ data PSType = PutCrit {_unPutCrit :: Creature} , _putDepth :: Float, _putStartPoint :: Point2, _putEndPoint :: Point2} | PutWall { _pwPoly :: [Point2] , _pwWall :: Wall } | PutSlideDr Door Wall Float Point2 Point2 --- | PutSlideDr Bool Color (World -> Bool) Float Point2 Point2 Float | PutDoor Color (World -> Bool) [(Point2,Point2)] | RandPS (State StdGen PSType) - | PutShape Shape | PutForeground ForegroundShape | PutWorldUpdate (PlacementSpot -> World -> World) | PutNothing diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs index b4f54030f..8b3ca553c 100644 --- a/src/Dodge/Default/World.hs +++ b/src/Dodge/Default/World.hs @@ -90,7 +90,6 @@ defaultWorld = World --, _keyConfig = defaultKeyConfigSDL -- , _config = defaultConfig , _sideEffects = return - , _foregroundShape = mempty , _shapes = mempty , _distortions = [] , _gameRooms = [] diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index c90308745..06e2725d8 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -42,17 +42,17 @@ initialAnoTree = OnwardList $ intersperse (AnTree corDoor) [ IntAnno $ AnTree . startRoom , AnRoom $ return airlock0 --- , AnRoom slowDoorRoom + , AnRoom slowDoorRoom -- , AnRoom $ roomCCrits 10 --- , AnTree firstBreather + , 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 +-- ] +-- +--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/Layout.hs b/src/Dodge/Layout.hs index 346ac8799..be5f1515a 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -10,7 +10,6 @@ import Dodge.Placement.PlaceSpot --import Dodge.LevelGen.Data import Dodge.LevelGen.StaticWalls import Dodge.LevelGen.LevelStructure -import Dodge.Room.Foreground import Dodge.Wall.Zone import Dodge.GameRoom import Dodge.Default.Wall @@ -21,9 +20,6 @@ import Geometry import qualified IntMapHelp as IM import Tile import RandomHelp -import Color -import Shape ---import Padding import qualified Data.Set as S import Data.List (nubBy) @@ -38,7 +34,6 @@ generateLevelFromRoomList :: IM.IntMap Room -> World -> World generateLevelFromRoomList gr' w = initWallZoning . randomCompass . setupWorldBounds - . placeWires . doAfterPlacements . doInPlacements . doOutPlacements @@ -86,35 +81,6 @@ shuffleRoomPos rm = do newPos <- shuffle $ _rmPos rm return $ rm & rmPos .~ newPos -placeWires :: World -> World -placeWires w = foldr placeRoomWires w (_genRooms w) - -placeRoomWires :: Room -> World -> World -placeRoomWires rm w = IM.foldr ($) w - $ IM.intersectionWith (placeWire rm) (_rmStartWires rm) (_rmEndWires rm) - -placeWire :: Room -> RoomWire -> RoomWire -> World -> World -placeWire rm (WallWire p _ h1) (WallWire q _ h2) = foregroundShape - %~ (col ( thinHighBarChain h2 (map (shiftPointBy rs) doOrdering) - <> barPP 1.5 (addZ h1 p) (addZ h2 p) - ) - <> - ) - where - --TODO use rmWalls for non convex rooms - --rmWalls = foldr cutWalls [] (_rmPolys rm) - doOrdering = orderPolygonAround rmcen (p:q:ps) - col | clockwise = colorSH red - | otherwise = colorSH red - rmps = concat $ _rmPolys rm - rmcen = centroid rmps - clockwise = isLHS rmcen p q - ps | clockwise = filter leftprightq rmps - | otherwise = filter rightpleftq rmps - leftprightq x = isLHS rmcen p x && isRHS rmcen q x - rightpleftq x = isRHS rmcen p x && isLHS rmcen q x - rs = _rmShift rm - doAfterPlacements :: World -> World doAfterPlacements gw = foldr doAfterPlacement gw (_genPlacements gw) diff --git a/src/Dodge/Placement/PlaceSpot.hs b/src/Dodge/Placement/PlaceSpot.hs index 33e93f1b0..5663cb04f 100644 --- a/src/Dodge/Placement/PlaceSpot.hs +++ b/src/Dodge/Placement/PlaceSpot.hs @@ -5,21 +5,15 @@ module Dodge.Placement.PlaceSpot ( placeSpot ) where ---import Dodge.LevelGen.LevelStructure import Dodge.Placement.Shift import Dodge.Data import Dodge.Path import Dodge.Placement.PlaceSpot.Block import Dodge.Placement.PlaceSpot.TriggerDoor ---import Dodge.LevelGen.Data import Dodge.Default.Wall import Dodge.ShiftPoint import Dodge.Base.NewID ---import Dodge.RandomHelp ---import Dodge.Placements.Spot import Geometry ---import Geometry.ConvexPoly -import Shape import qualified IntMapHelp as IM import Color @@ -109,7 +103,6 @@ placeSpotID ps pt w = case pt of wl w PutLineBlock wl wdth dpth a b -> placeLineBlock wl wdth dpth (doShift a) (doShift b) w PutWall qs wl -> (0,placeWallPoly (map doShift qs) wl w) - PutShape sh -> placeShape sh p rot w PutNothing -> (0,w) PutID i -> (i, w) PutWorldUpdate f -> (0, w & f ps) @@ -121,11 +114,6 @@ placeSpotID ps pt w = case pt of rot = _psRot ps doShift = shiftPointBy (p,rot) -placeShape :: Shape -> Point2 -> Float -> World -> (Int, World) -placeShape sh p rot w = (0, w & foregroundShape %~ (newsh <>)) - where - newsh = (uncurryV translateSHf p . rotateSH rot) sh - evaluateRandPS :: State StdGen PSType -> PlacementSpot -> World -> (Int,World) evaluateRandPS rgen ps w = placeSpotID ps evaluatedType (set randGen g w) where diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index 7732851ff..fad583d1e 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/src/Dodge/Render/ShapePicture.hs @@ -20,7 +20,6 @@ import Dodge.Wall.Zone import Geometry import Geometry.Zone import ShapePicture -import Shape import Picture import Sound.Data import Geometry.ConvexPoly @@ -35,7 +34,7 @@ import qualified Streaming.Prelude as S -- TODO only filter out shapes outside the range of the furthest shown light source worldSPic :: Configuration -> World -> SPic worldSPic cfig w = - (extraShapes w, extraPics cfig w) + (mempty, extraPics cfig w) --(mempty, extraPics cfig w) <> foldMap (dbArg _prDraw) (filtOn _prPos _props) <> foldMap (shiftDraw _blPos _blDir _blDraw) (filtOn _blPos _blocks) @@ -60,9 +59,6 @@ cullPoint cfig w p | debugOn Close_shape_culling cfig = pointInPolygon p (_boundBox w) | otherwise = dist (_cameraCenter w) p < _viewDistance w -extraShapes :: World -> Shape -extraShapes = _foregroundShape - -- TODO filter out pictures not in the frame extraPics :: Configuration -> World -> Picture extraPics cfig w = pictures (_decorations w) diff --git a/src/Dodge/Room/Foreground.hs b/src/Dodge/Room/Foreground.hs index 9dac2b0fd..56655fa9b 100644 --- a/src/Dodge/Room/Foreground.hs +++ b/src/Dodge/Room/Foreground.hs @@ -141,12 +141,11 @@ radBounds :: (Float, Float,Float,Float) -> Float radBounds (n,s,e,w) = max (n-s) (e-w) / 2 girderV' - :: Float -- ^ "cap" size - -> Float -- ^ height + :: Float -- ^ height -> Float -- ^ distance between cross bars -> Float -- ^ width -> Point2 -> Point2 -> ForegroundShape -girderV' csize h d w x y = defaultForeground +girderV' h d w x y = defaultForeground & fsPos .~ m & fsRad .~ dist m x & fsSPic .~ noPic sh @@ -157,7 +156,7 @@ girderV' csize h d w x y = defaultForeground sh = thinHighBar h (x' -.- n) (x' +.+ n) <> thinHighBar h (y' -.- n) (y' +.+ n) <> girderV h d w x' y' - n = csize *.* vNormal (normalizeV (x' -.- y')) + n = min (w + 10) 20 *.* vNormal (normalizeV (x' -.- y')) girderV :: Float -- ^ height diff --git a/src/Dodge/Room/Modify/Girder.hs b/src/Dodge/Room/Modify/Girder.hs index 8e3818417..7d9fbce88 100644 --- a/src/Dodge/Room/Modify/Girder.hs +++ b/src/Dodge/Room/Modify/Girder.hs @@ -151,13 +151,13 @@ addGirderLights rm = do midw = wiToFloat rm midi extragirderpos = nub $ map (\(wi,hi) -> (wi - midi, hi)) lpis extragirders = mapMaybe (\(i,hi) -> case i of - x | x < 0 -> Just $ girderV' 20 96 20 10 (V2 (midw - 10) (hiToFloat rm hi)) + x | x < 0 -> Just $ girderV' 96 20 10 (V2 (midw - 10) (hiToFloat rm hi)) (V2 0 (hiToFloat rm hi)) - x | x > 0 -> Just $ girderV' 20 96 20 10 (V2 (midw + 10) (hiToFloat rm hi)) + x | x > 0 -> Just $ girderV' 96 20 10 (V2 (midw + 10) (hiToFloat rm hi)) (V2 w (hiToFloat rm hi)) _ -> Nothing ) extragirderpos return $ rm & rmPmnts .++~ - (sps0 (PutForeground $ girderV' 20 96 20 10 (V2 midw 0) (V2 midw h)) + (sps0 (PutForeground $ girderV' 96 20 10 (V2 midw 0) (V2 midw h)) : map (\p -> sps (PS p 0) (PutLS $ lsColPos 0.75 (V3 0 0 90))) lps ) ++ map (sps0 . PutForeground) extragirders diff --git a/src/Shader/Poke.hs b/src/Shader/Poke.hs index 8ee071921..f6774f27d 100644 --- a/src/Shader/Poke.hs +++ b/src/Shader/Poke.hs @@ -106,31 +106,54 @@ pokeTopPrism :: Int -> Ptr Float -> Ptr GLushort -> IO () pokeTopPrism size ptr iptr ieptr counts svs = do nv <- UMV.unsafeRead counts 0 + nshapeindices <- UMV.unsafeRead counts 1 + nedgeindices <- UMV.unsafeRead counts 2 -- MP.bindM3 (\_ _ _ -> return ()) -- (UV.mapM_ (pokeTopPrismIndex nv iptr counts) (memoTopPrismIndices V.! size)) -- (UV.mapM_ (pokeTopPrismEdgeIndex nv ieptr counts) (memoTopPrismEdgeIndices V.! size)) -- (VS.mapM_ (pokeJustV ptr counts) (VS.fromList svs) ) - UV.mapM_ (pokeTopPrismIndex nv iptr counts) (memoTopPrismIndices V.! size) - UV.mapM_ (pokeTopPrismEdgeIndex nv ieptr counts) (memoTopPrismEdgeIndices V.! size) - VS.mapM_ (pokeJustV ptr counts) (VS.fromList svs) + nv' <- VS.foldM (pokeJustV' ptr) nv (VS.fromList svs) + nshapeindices' <- UV.foldM (pokeTopPrismIndex' nv iptr) nshapeindices + (memoTopPrismIndices V.! size) + nedgeindices' <- UV.foldM (pokeTopPrismEdgeIndex' nv ieptr) nedgeindices + (memoTopPrismEdgeIndices V.! size) + UMV.unsafeWrite counts 0 nv' + UMV.unsafeWrite counts 1 nshapeindices' + UMV.unsafeWrite counts 2 nedgeindices' -pokeTopPrismEdgeIndex :: Int -> Ptr GLushort - -> UMV.MVector (PrimState IO) Int +pokeTopPrismEdgeIndex' :: Int -> Ptr GLushort + -> Int -> Int - -> IO () -pokeTopPrismEdgeIndex nv eiptr counts ioff = do - nei <- UMV.unsafeRead counts 2 - pokeElemOff eiptr nei (fromIntegral $ nv + ioff) - UMV.unsafeModify counts (+1) 2 + -> IO Int +pokeTopPrismEdgeIndex' nv eiptr nedgeindices ioff = do + pokeElemOff eiptr nedgeindices (fromIntegral $ nv + ioff) + return $ nedgeindices + 1 -pokeTopPrismIndex :: Int -> Ptr GLushort - -> UMV.MVector (PrimState IO) Int +--pokeTopPrismEdgeIndex :: Int -> Ptr GLushort +-- -> UMV.MVector (PrimState IO) Int +-- -> Int +-- -> IO () +--pokeTopPrismEdgeIndex nv eiptr counts ioff = do +-- nei <- UMV.unsafeRead counts 2 +-- pokeElemOff eiptr nei (fromIntegral $ nv + ioff) +-- UMV.unsafeModify counts (+1) 2 + +pokeTopPrismIndex' :: Int -> Ptr GLushort + -> Int -> Int - -> IO () -pokeTopPrismIndex nv iptr counts ioff = do - ni <- UMV.unsafeRead counts 1 - pokeElemOff iptr ni (fromIntegral $ nv + ioff) - UMV.unsafeModify counts (+1) 1 + -> IO Int +pokeTopPrismIndex' nv iptr nshapeindices ioff = do + pokeElemOff iptr nshapeindices (fromIntegral $ nv + ioff) + return $ nshapeindices + 1 + +--pokeTopPrismIndex :: Int -> Ptr GLushort +-- -> UMV.MVector (PrimState IO) Int +-- -> Int +-- -> IO () +--pokeTopPrismIndex nv iptr counts ioff = do +-- ni <- UMV.unsafeRead counts 1 +-- pokeElemOff iptr ni (fromIntegral $ nv + ioff) +-- UMV.unsafeModify counts (+1) 1 memoTopPrismEdgeIndices :: V.Vector (UV.Vector Int) memoTopPrismEdgeIndices = V.generate 10 @@ -164,9 +187,11 @@ topPrismIndices n = concatMap f [1..n-2] -- triangles on top face g x = [2*x,2*x+1,2*x+3 ,2*x,2*x+3,2*x+2] -pokeJustV :: Ptr Float -> UMV.MVector (PrimState IO) Int -> ShapeV -> IO () -pokeJustV ptr counts sh = do - nv <- UMV.unsafeRead counts 0 +pokeJustV' :: Ptr Float + -> Int + -> ShapeV + -> IO Int +pokeJustV' ptr nv sh = do let off i = nv*7 + i pokeElemOff ptr (off 0) a pokeElemOff ptr (off 1) b @@ -175,11 +200,27 @@ pokeJustV ptr counts sh = do pokeElemOff ptr (off 4) e pokeElemOff ptr (off 5) f pokeElemOff ptr (off 6) g - UMV.unsafeModify counts (+1) 0 + return (nv + 1) where V3 a b c = _svPos sh V4 d e f g = _svCol sh +--pokeJustV :: Ptr Float -> UMV.MVector (PrimState IO) Int -> ShapeV -> IO () +--pokeJustV ptr counts sh = do +-- nv <- UMV.unsafeRead counts 0 +-- let off i = nv*7 + i +-- pokeElemOff ptr (off 0) a +-- pokeElemOff ptr (off 1) b +-- pokeElemOff ptr (off 2) c +-- pokeElemOff ptr (off 3) d +-- pokeElemOff ptr (off 4) e +-- pokeElemOff ptr (off 5) f +-- pokeElemOff ptr (off 6) g +-- UMV.unsafeModify counts (+1) 0 +-- where +-- V3 a b c = _svPos sh +-- V4 d e f g = _svCol sh + pokeLayVerxs :: MV.MVector (PrimState IO) FullShader -> UMV.MVector (PrimState IO) Int