Remove parallelization of pokeTopPrism

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

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 = 
+placeShape sh p rot w = (0, w & foregroundShape %~ (newsh <>))
-    (0, w & foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>))
+  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)

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 :: World -> Picture
-drawBoundingBox cfig w = setLayer DebugLayer $ color green $ line $ (x:xs) ++ [x]
+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)

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

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

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
+    f w' i -- = w' & walls . ix i . wlSeen .~ True -- this is much simpler, but leaks
-
+        = w' { _walls = IM.adjust mw i $ _walls w' }
---    wallsToUpdate = concatMap (\p -> visibleWalls vPos (vPos +.+p) $ wallsAlongLine vPos (vPos +.+ p) w)
+    mw wl = wl {_wlSeen = True}
---                             $ nRays 20
 
 --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)

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 :: Point2 -> World -> Stream (Of Cloud) Identity ()
---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 = S.each . f $ w ^? cloudsZone . znObjects . ix x . ix y
-cloudsNearPoint p w = f (IM.lookup x (_znObjects $ _cloudsZone w) >>= IM.lookup y)
   where 
     (x,y) = cloudZoneOfPoint p
     f Nothing = []

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 ())
+--    MP.bindM3 (\_ _ _ -> return ())
-        (UV.mapM_ (pokeTopPrismIndex nv iptr      counts) (memoTopPrismIndices     V.! size))
+--        (UV.mapM_ (pokeTopPrismIndex nv iptr      counts) (memoTopPrismIndices     V.! size))
-        (UV.mapM_ (pokeTopPrismEdgeIndex nv ieptr counts) (memoTopPrismEdgeIndices V.! size))
+--        (UV.mapM_ (pokeTopPrismEdgeIndex nv ieptr counts) (memoTopPrismEdgeIndices V.! size))
-        (VS.mapM_ (pokeJustV ptr counts)                  (VS.fromList svs)                 )
+--        (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