From 9af636aa830169f0f5645305d4955ba9a25e152b Mon Sep 17 00:00:00 2001 From: justin Date: Sun, 13 Feb 2022 09:24:27 +0000 Subject: [PATCH] Fix bug in line zoning by using less ambitious algorithm --- src/Dodge/Update.hs | 9 ++++-- src/Dodge/WallCreatureCollisions.hs | 6 ++-- src/Dodge/World.hs | 5 ---- src/Dodge/Zone.hs | 10 +++++-- src/Geometry.hs | 2 +- src/Geometry/Zone.hs | 46 +++++++++++++++++++++++++++-- src/ListHelp.hs | 4 +-- src/Preload/Render.hs | 1 - src/Shader/Compile.hs | 1 - src/Shader/Poke.hs | 3 +- 10 files changed, 65 insertions(+), 22 deletions(-) delete mode 100644 src/Dodge/World.hs diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 4dc62c446..25a13da67 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -143,7 +143,7 @@ updateInstantParticles w = case _instantParticles w of in updateInstantParticles $ w' & particles %~ (catMaybes ps' ++) updateMIM :: ASetter' World (IM.IntMap a) -> (a -> a -> Maybe a) -> World -> World -updateMIM f up w = w & f %~ IM.mapMaybe (dbArg up) +updateMIM f up = f %~ IM.mapMaybe (dbArg up) -- Note that this updates the randgen --updateCreatures :: World -> World @@ -160,12 +160,15 @@ updateMIM f up w = w & 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 +-- wallsToUpdate = concatMap (\p -> visibleWalls vPos (vPos +.+p) $ _walls w) +-- $ nRays 20 markWallSeen :: World -> Wall -> World markWallSeen w wl = w { _walls = IM.adjust mw (_wlID wl) $ _walls w } @@ -269,7 +272,7 @@ crCrSpring c1 c2 w {- Finds the visible walls from a point to another point. -} visibleWalls :: Point2 -> Point2 -> IM.IntMap Wall -> [Wall] visibleWalls p1 p2 ws - = takeUntil theTest + = takeUntil isOpaque . map snd . sortOn (dist p1 . fromJust . fst) . filter (isJust . fst) @@ -277,7 +280,7 @@ visibleWalls p1 p2 ws $ IM.elems ws where f wl = (uncurry intersectSegSeg (_wlLine wl) p1 p2, wl) - theTest wl = _wlOpacity wl /= Opaque + isOpaque wl = _wlOpacity wl == Opaque updateDelayedEvents :: World -> World updateDelayedEvents w = let (neww,newde) = mapAccumR f w (_delayedEvents w) diff --git a/src/Dodge/WallCreatureCollisions.hs b/src/Dodge/WallCreatureCollisions.hs index dd3cd3fab..5ac640dcd 100644 --- a/src/Dodge/WallCreatureCollisions.hs +++ b/src/Dodge/WallCreatureCollisions.hs @@ -81,11 +81,13 @@ pushOrCrush wls cr = case mapMaybe (pushOutFromWall (_crRad cr) cpos) wls of -- note the inclusion of endpoints in circOnSeg crOnWall :: Creature -> World -> Bool -crOnWall cr w = any (\(a,b) -> circOnSeg a b p r) wls +crOnWall cr = any (\(a,b) -> circOnSeg a b p r) + . fmap _wlLine + . IM.filter (not . _wlWalkable) + . wallsNearPoint p where p = _crPos cr r = _crRad cr - wls = fmap _wlLine . IM.filter (not . _wlWalkable) $ wallsNearPoint p w -- assumes that the wall is orientated -- assumes wall points are different diff --git a/src/Dodge/World.hs b/src/Dodge/World.hs deleted file mode 100644 index 7474f5a41..000000000 --- a/src/Dodge/World.hs +++ /dev/null @@ -1,5 +0,0 @@ -{- | -Placeholder... not sure of its purpose, but might deal with pure world change functions. -The world datatype itself is very intertwined with the creature, weapon, etc datatypes. - -} -module Dodge.World where diff --git a/src/Dodge/Zone.hs b/src/Dodge/Zone.hs index ff798e10f..23204ddcd 100644 --- a/src/Dodge/Zone.hs +++ b/src/Dodge/Zone.hs @@ -29,6 +29,9 @@ import Data.List import qualified Data.IntMap.Strict as IM import qualified Data.IntSet as IS +--flattenZones :: Zone (IM.IntMap a) -> IM.IntMap a +--flattenZones = flattenIMIMIM . _znObjects + zoneSize :: Float zoneSize = 50 @@ -68,10 +71,12 @@ zoneOfLine (V2 aa ab) (V2 ba bb) $ digitalLine (zoneOfPoint (V2 aa ab)) (zoneOfPoint (V2 ba bb)) where f (x,y) = [(p,r) | p <-[x-1,x,x+1] , r<-[y-1,y,y+1]] + --f (x,y) = [(p,r) | p <-[x-2..x+2] , r<-[y-2..y+2]] zoneOfLineIntMap :: Point2 -> Point2 -> IM.IntMap IS.IntSet --{-# INLINE zoneOfLineIntMap #-} -zoneOfLineIntMap = ddaExt zoneSize +--zoneOfLineIntMap = ddaExt zoneSize +zoneOfLineIntMap = ddaSq zoneSize zoneOfCircle :: Point2 -> Float -> [(Int,Int)] zoneOfCircle p r = concatMap zoneNearPoint $ divideCircle (1.5 * zoneSize) p r @@ -148,7 +153,8 @@ cloudsNearPoint p w = f (IM.lookup x (_znObjects $ _cloudsZone w) >>= IM.lookup -- within this function wallsAlongLine :: Point2 -> Point2 -> World -> IM.IntMap Wall --{-# INLINE wallsAlongLine #-} -wallsAlongLine a b w = IM.foldlWithKey' g IM.empty kps +wallsAlongLine a b w = + IM.foldlWithKey' g IM.empty kps where g m x s = IM.union (IM.unions (IM.restrictKeys (f x $ _znObjects $ _wallsZone w) s)) m kps = zoneOfLineIntMap a b diff --git a/src/Geometry.hs b/src/Geometry.hs index 20e0023b4..d4f919d25 100644 --- a/src/Geometry.hs +++ b/src/Geometry.hs @@ -140,7 +140,7 @@ prependTwo sep (x:y:xs) = sep : x : y : prependTwo sep (y:xs) -- | Return n equidistant points on a circle with a radius of 600. nRays :: Int -> [Point2] -nRays n = take n $ iterate (rotateV (2*pi/fromIntegral n)) (V2 600 0) +nRays n = nRaysRad n 600 -- | Return n equidistant points on a circle with a radius of x. nRaysRad :: Int -> Float -> [Point2] nRaysRad n x = take n $ iterate (rotateV (2*pi/fromIntegral n)) (V2 x 0) diff --git a/src/Geometry/Zone.hs b/src/Geometry/Zone.hs index c20623efb..1299d1185 100644 --- a/src/Geometry/Zone.hs +++ b/src/Geometry/Zone.hs @@ -1,8 +1,9 @@ --{-# LANGUAGE TupleSections #-} module Geometry.Zone ( ddaExt - ) - where + , ddaExt' + , ddaSq + ) where import Geometry.Data import Data.Foldable @@ -77,10 +78,49 @@ sizeZoneOfPoint' s = fmap (divTo s) -- | y > x = [x .. y] -- | otherwise = [y .. x] +-- | Determines a "square" zone of points for a line +ddaSq :: Float -> V2 Float -> V2 Float -> IM.IntMap IS.IntSet +ddaSq s (V2 sx sy) (V2 ex ey) = IM.fromSet (const ys) xs + where + maxMin a b | a >= b = (a,b) + | otherwise = (b,a) + (maxx,minx) = maxMin (divTo s sx) (divTo s ex) + (maxy,miny) = maxMin (divTo s sy) (divTo s ey) + xs = IS.fromDistinctAscList [minx-1..maxx+1] + ys = IS.fromDistinctAscList [miny-1..maxy+1] + -- | Determines which horizontal and vertical lines on a grid are crossed by a -- line. For each adds the x-y index of the square to the right or above the -- crossed grid line. Also adds the index of the square containing the start -- point. +ddaExt' :: Float -> V2 Float -> V2 Float -> IM.IntMap IS.IntSet +ddaExt' s sp@(V2 sx sy) ep@(V2 ex ey) + | x1 <= x2 = addsp . addys . IM.fromDistinctAscList $ zip [x1 .. x2] + $ map (IS.singleton . divTo s) [x1y,x1y+ydx..] + | otherwise = ddaExt' s ep sp + where + addsp im = let V2 x y = sizeZoneOfPoint' s sp + in insertXY im (x,y) + x1 = divTo s sx + x2 = divTo s ex + x1y = fx' sp ep $ s * fromIntegral x1 + ydx = s * ydx' sp ep + addys m = add2s m ypairs + y1 = divTo s sy + y2 = divTo s ey + y1x = fy' sp ep $ s * fromIntegral y1 + y2x = fy' sp ep $ s * fromIntegral y2 + xdy = s * xdy' sp ep + ypairs + | y1 <= y2 = zip (map (divTo s) [y1x,y1x+xdy..]) + [y1 .. y2] + | otherwise = zip (map (divTo s) [y2x,y2x+xdy..]) + [y2-1 .. y1-1] +-- | Determines which horizontal and vertical lines on a grid are crossed by a +-- line. For each adds the x-y index of the square to the right or above the +-- crossed grid line. Also adds the index of the square containing the start +-- point. +-- Not correct, eg ddaExt 10 (V2 40 50) (V2 0 0) ddaExt :: Float -> V2 Float -> V2 Float -> IM.IntMap IS.IntSet ddaExt s sp@(V2 sx sy) ep@(V2 ex ey) | x1 <= x2 = addsp . addys . IM.fromDistinctAscList $ zip [x1 .. x2] @@ -89,7 +129,7 @@ ddaExt s sp@(V2 sx sy) ep@(V2 ex ey) $ map (IS.singleton . divTo s) [x2y,x2y+ydx..] where addsp im = let V2 x y = sizeZoneOfPoint' s sp - in insertXY im (x,y) + in insertXY im (x,y) x1 = divTo s sx x2 = divTo s ex x1y = fx' sp ep $ s * fromIntegral x1 diff --git a/src/ListHelp.hs b/src/ListHelp.hs index eee1e3135..c3cb3ce8f 100644 --- a/src/ListHelp.hs +++ b/src/ListHelp.hs @@ -1,6 +1,6 @@ module ListHelp - (module Data.List - ,initOrNull + ( module Data.List + , initOrNull , insertOver , swapIndices , (!?) diff --git a/src/Preload/Render.hs b/src/Preload/Render.hs index f145d3b98..76eaadcad 100644 --- a/src/Preload/Render.hs +++ b/src/Preload/Render.hs @@ -239,4 +239,3 @@ cleanUpRenderPreload pd = do --mapM_ freeShaderPointers $ _pictureShaders pd freeShaderPointers $ _lightingWallShadShader pd freeShaderPointers $ _fullscreenShader pd - diff --git a/src/Shader/Compile.hs b/src/Shader/Compile.hs index 36d4c803f..937d68043 100644 --- a/src/Shader/Compile.hs +++ b/src/Shader/Compile.hs @@ -243,4 +243,3 @@ compileAndCheckShader str (theShaderType,sourceCode) = do bufferOffset :: Integral a => a -> Ptr b bufferOffset = plusPtr nullPtr . (* floatSize) . fromIntegral - diff --git a/src/Shader/Poke.hs b/src/Shader/Poke.hs index eeffe8e90..c9bfc008f 100644 --- a/src/Shader/Poke.hs +++ b/src/Shader/Poke.hs @@ -26,7 +26,7 @@ pokeVerxs -> UMV.MVector (PrimState IO) Int -> Picture -> IO () -pokeVerxs vbos count vxs = VS.mapM_ (pokeVerx vbos count) $ VS.fromList vxs +pokeVerxs vbos count = VS.mapM_ (pokeVerx vbos count) . VS.fromList pokeVerx :: MV.MVector (PrimState IO) FullShader -> UMV.MVector (PrimState IO) Int -> Verx -> IO () pokeVerx vbos offsets Verx{_vxPos=thePos,_vxCol=theCol,_vxExt=ext,_vxShadNum=theShadNum} = do @@ -243,4 +243,3 @@ pokePoint33 ptr n (V3 a b c,V3 d e f) = do return (n+1) where off i = n*6 + i -