From c3f9dad233b35cf40a192ccfa47820f4b6636dbc Mon Sep 17 00:00:00 2001 From: justin Date: Sun, 26 Jun 2022 14:26:39 +0100 Subject: [PATCH] Remove parallelization of pokeTopPrism --- src/Dodge/CullBox.hs | 17 +++------------- src/Dodge/Placement/PlaceSpot.hs | 5 +++-- src/Dodge/Render/ShapePicture.hs | 9 ++++----- src/Dodge/Room/Link.hs | 5 ++++- src/Dodge/ShiftPoint.hs | 3 ++- src/Dodge/Update.hs | 34 ++++---------------------------- src/Dodge/Zone.hs | 5 ++--- src/Shader/Poke.hs | 13 +++++++----- 8 files changed, 30 insertions(+), 61 deletions(-) diff --git a/src/Dodge/CullBox.hs b/src/Dodge/CullBox.hs index 817090f6f..e69f0d260 100644 --- a/src/Dodge/CullBox.hs +++ b/src/Dodge/CullBox.hs @@ -1,8 +1,7 @@ module Dodge.CullBox - ( makeBoundBox - , updateBounds + ( updateBounds ) - where + where import Dodge.Data import Dodge.Base.Window import Geometry @@ -20,19 +19,9 @@ findBoundDists cfig w hw = halfWidth cfig hh = halfHeight cfig -makeBoundBox :: Configuration -> World -> [Point2] ---cullBox cfig w = farWallPoints cp w -makeBoundBox cfig w' - | debugOn Bound_box_screen cfig = screenPolygon cfig w' - | otherwise = let (n,s,e,w) = f $ farWallDistDirection (_cameraCenter w') w' - in map ((+.+ _cameraCenter w') . rotateV (_cameraRot w') ) $ rectNSWE n s w e - where - f (Just a,Just b,Just c,Just d) = (max 0 a,min 0 b,max 0 c,min 0 d) - f _ = (0,0,0,0) - updateBounds :: Configuration -> World -> World updateBounds cfig w = w & boundDist .~ bdists - & boundBox .~ map ( (+.+ _cameraCenter w) . rotateV (_cameraRot w) ) (rectNSWE n s w' e) + & boundBox .~ map ( (+.+ _cameraCenter w) . rotateV (_cameraRot w) ) (rectNSWE n s w' e) where bdists@(n,s,e,w') = findBoundDists cfig w diff --git a/src/Dodge/Placement/PlaceSpot.hs b/src/Dodge/Placement/PlaceSpot.hs index d0c74f7e5..14cd85230 100644 --- a/src/Dodge/Placement/PlaceSpot.hs +++ b/src/Dodge/Placement/PlaceSpot.hs @@ -121,8 +121,9 @@ placeSpotID ps pt w = case pt of doShift = shiftPointBy (p,rot) placeShape :: Shape -> Point2 -> Float -> World -> (Int, World) -placeShape sh p rot w = - (0, w & foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>)) +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) diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index 6dd5c665b..e3883d4cc 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/src/Dodge/Render/ShapePicture.hs @@ -2,7 +2,6 @@ module Dodge.Render.ShapePicture ( worldSPic ) where import Dodge.ShortShow -import Dodge.CullBox import Dodge.Config.Data import Dodge.Render.InfoBox import Dodge.Debug.Picture @@ -79,7 +78,7 @@ extraPics cfig w = pictures (_decorations w) <> drawWallIDs cfig w <> drawPathing cfig w <> drawCrInfo cfig w - <> cfigdraw Show_bound_box drawBoundingBox + <> cfigdraw Show_bound_box (const drawBoundingBox) <> cfigdraw Show_wall_search_rays (const drawWallSearchRays) <> cfigdraw Show_dda_test (const drawDDATest) where @@ -129,10 +128,10 @@ drawWallSearchRays w = runIdentity $ S.foldMap_ f $ S.map fst $ allVisibleWalls testPic :: Configuration -> World -> Picture testPic _ _ = mempty -drawBoundingBox :: Configuration -> World -> Picture -drawBoundingBox cfig w = setLayer DebugLayer $ color green $ line $ (x:xs) ++ [x] +drawBoundingBox :: World -> Picture +drawBoundingBox w = setLayer DebugLayer $ color green $ line $ (x:xs) ++ [x] where - (x:xs) = makeBoundBox cfig w + (x:xs) = _boundBox w clDraw :: Cloud -> Picture clDraw c = translate3 (_clPos c) (_clPict c c) diff --git a/src/Dodge/Room/Link.hs b/src/Dodge/Room/Link.hs index b2feb70ca..8fc30b132 100644 --- a/src/Dodge/Room/Link.hs +++ b/src/Dodge/Room/Link.hs @@ -86,4 +86,7 @@ shiftLinkBy (pos,rot) = overLnkPosDir f f (p,r) = (shiftPointBy (pos,rot) p, r + rot) shiftPathBy :: (Point2,Float) -> (Point2,Point2) -> (Point2,Point2) -shiftPathBy s (p1,p2) = (shiftPointBy s p1, shiftPointBy s p2) +shiftPathBy s (p1,p2) = sp1 `seq` sp2 `seq` (sp1, sp2) + where + sp1 = shiftPointBy s p1 + sp2 = shiftPointBy s p2 diff --git a/src/Dodge/ShiftPoint.hs b/src/Dodge/ShiftPoint.hs index f953232c6..2c5881e2b 100644 --- a/src/Dodge/ShiftPoint.hs +++ b/src/Dodge/ShiftPoint.hs @@ -1,8 +1,9 @@ +{-# LANGUAGE BangPatterns #-} module Dodge.ShiftPoint where import Geometry shiftPointBy :: (Point2,Float) -> Point2 -> Point2 -shiftPointBy (pos,rot) p = pos +.+ rotateV rot p +shiftPointBy (pos,rot) !p = pos +.+ rotateV rot p invShiftPointBy :: (Point2,Float) -> Point2 -> Point2 invShiftPointBy (p1,r) p2 = rotateV (-r) $ p2 -.- p1 diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 99460567a..6f5b01337 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -284,20 +284,12 @@ updateMIM f up = f %~ IM.mapMaybe (dbArg up) ppEvents :: World -> World ppEvents w = IM.foldl' (flip $ \pp -> _ppEvent pp pp) w $ _pressPlates w --- this is not working correctly, maybe a problem with wallsAlongLine ---updateSeenWalls :: World -> World ---updateSeenWalls w = foldl' markWallSeen w wallsToUpdate --- where --- vPos = _cameraViewFrom w --- wallsToUpdate = concatMap (\p -> visibleWalls vPos (vPos +.+p) $ wallsAlongLine vPos (vPos +.+ p) w) --- $ nRays 20 updateSeenWalls :: World -> World updateSeenWalls w = runIdentity $ S.fold_ f w id (S.map (_wlID . snd) $ allVisibleWalls w) where - f w' i = w' & walls . ix i . wlSeen .~ True - --- wallsToUpdate = concatMap (\p -> visibleWalls vPos (vPos +.+p) $ wallsAlongLine vPos (vPos +.+ p) w) --- $ nRays 20 + f w' i -- = w' & walls . ix i . wlSeen .~ True -- this is much simpler, but leaks + = w' { _walls = IM.adjust mw i $ _walls w' } + mw wl = wl {_wlSeen = True} --markWallSeen :: World -> Wall -> World --markWallSeen w wl = w { _walls = IM.adjust mw (_wlID wl) $ _walls w } @@ -339,34 +331,16 @@ updateCloud w c newVel@(V3 _ _ nvz) = (0.95 *.*.* springVels) +.+.+ V3 0 0 (0.001 * vertVel) newVel2 = stripZ newVel vertVel = _clAlt c - opz - springVels = foldl' (clClSpringVel c) (_clVel c) (cloudsNearPoint oldPos2 w) + springVels = runIdentity $ S.fold_ (clClSpringVel c) (_clVel c) id (cloudsNearPoint oldPos2 w) oldPos@(V3 _ _ opz) = _clPos c oldPos2 = stripZ oldPos newPos@(V3 _ _ npz) = oldPos +.+.+ newVel newPos2 = stripZ newPos - -- the following only tests for the first collision with a wall - --hitWl = collidePointAnyWallsReflect oldPos2 newPos2 $ wallsNearPoint newPos2 w hitWl = bouncePoint (const True) 1 oldPos2 newPos2 w finalPos = addZ (min 74 npz) $ maybe newPos2 fst hitWl -- allowing clouds at/above height 75 causes graphical glitches 22.05.23 finalVel = addZ nvz $ maybe newVel2 snd hitWl ---updateCloud :: World -> Cloud -> Maybe Cloud ---updateCloud w c --- | _clTimer c < 1 = Nothing --- | otherwise = Just $ c --- & clPos .~ finalPos --- & clVel .~ finalVel --- & clTimer -~ 1 --- where --- newVel = 0.95 *.* springVels --- springVels = foldl' (clClSpringVel c) (_clVel c) (cloudsNearPoint oldPos w) --- oldPos = _clPos c --- newPos = oldPos +.+ newVel --- hitWl = collideCircWalls' oldPos newPos 5 $ wallsNearPoint newPos w --- finalPos = maybe newPos fst hitWl --- finalVel = maybe newVel snd hitWl - clClSpringVel :: Cloud -> Point3 -> Cloud -> Point3 clClSpringVel a v b | dist3 pa pb < radDist = v +.+.+ 0.1 *.*.* normalizeV3 (pa -.-.- pb) diff --git a/src/Dodge/Zone.hs b/src/Dodge/Zone.hs index e2593455f..867096f56 100644 --- a/src/Dodge/Zone.hs +++ b/src/Dodge/Zone.hs @@ -157,9 +157,8 @@ lookLookup i j z = case IM.lookup i z of lookLookups :: [(Int,Int)] -> IM.IntMap (IM.IntMap a) -> [a] lookLookups xs z = mapMaybe (flip (uncurry lookLookup) z) xs -cloudsNearPoint :: Point2 -> World -> [Cloud] ---cloudsNearPoint p w = IM.unions [f b $ f a $ _cloudsZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]] -cloudsNearPoint p w = f (IM.lookup x (_znObjects $ _cloudsZone w) >>= IM.lookup y) +cloudsNearPoint :: Point2 -> World -> Stream (Of Cloud) Identity () +cloudsNearPoint p w = S.each . f $ w ^? cloudsZone . znObjects . ix x . ix y where (x,y) = cloudZoneOfPoint p f Nothing = [] diff --git a/src/Shader/Poke.hs b/src/Shader/Poke.hs index c06e56e14..8ee071921 100644 --- a/src/Shader/Poke.hs +++ b/src/Shader/Poke.hs @@ -20,7 +20,7 @@ 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 Control.Monad.Primitive -import qualified Control.Monad.Parallel as MP +--import qualified Control.Monad.Parallel as MP pokeVerxs :: MV.MVector (PrimState IO) FullShader @@ -106,10 +106,13 @@ pokeTopPrism :: Int -> Ptr Float -> Ptr GLushort -> IO () pokeTopPrism size ptr iptr ieptr counts svs = do nv <- UMV.unsafeRead counts 0 - 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) ) +-- 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) pokeTopPrismEdgeIndex :: Int -> Ptr GLushort -> UMV.MVector (PrimState IO) Int