From 40f5d22d88ffd256a22955deb041550d1d2e780b Mon Sep 17 00:00:00 2001 From: justin Date: Thu, 26 Mar 2026 13:03:58 +0000 Subject: [PATCH] Cleanup --- src/Dodge/Placement/Instance/Door.hs | 2 +- src/Dodge/TestString.hs | 6 +-- src/Dodge/WallCreatureCollisions.hs | 63 ++++------------------------ 3 files changed, 11 insertions(+), 60 deletions(-) diff --git a/src/Dodge/Placement/Instance/Door.hs b/src/Dodge/Placement/Instance/Door.hs index 1f570c25f..b22eabb4a 100644 --- a/src/Dodge/Placement/Instance/Door.hs +++ b/src/Dodge/Placement/Instance/Door.hs @@ -63,7 +63,7 @@ divideDoorPane mid wl soff dr ppairs g = case ppairs of thedoor = dr & drPushedBy .~ maybe PushesItself PushedBy mid putAutoDoor :: Point2 -> Point2 -> Placement -putAutoDoor a b = Placement (PS 0 0) (PutCoord a) Nothing Nothing $ \_ apl -> +putAutoDoor a b = pt0 (PutCoord a) $ \apl -> Just $ Placement (PS 0 0) (PutCoord b) Nothing Nothing $ \w bpl -> let x = w ^?! gwWorld . coordinates . ix (apl ^?! plMID . _Just) diff --git a/src/Dodge/TestString.hs b/src/Dodge/TestString.hs index 7c3722255..1bcea0b47 100644 --- a/src/Dodge/TestString.hs +++ b/src/Dodge/TestString.hs @@ -33,12 +33,8 @@ import Data.Monoid import RandomHelp testStringInit :: Universe -> [String] +testStringInit _ = mempty --testStringInit u = [show $ u ^? uvWorld . input . mouseContext . mcoRotateDist] -testStringInit u = --fmap show (u ^.. uvWorld . cWorld . lWorld . creatures . each . crHP . _HP) - fmap show (u ^.. uvWorld . cWorld . lWorld . creatures . each . crPos . _xy) - <> fmap show (u ^.. uvWorld . cWorld . lWorld . creatures . each . crOldPos . _xy) - <> fmap show (u ^.. uvWorld . cWorld . lWorld . creatures . each . crWallTouch) - <> fmap show (u ^.. uvWorld . cWorld . lWorld . debris . each . dbPos) -- (fmap show $ u ^.. uvWorld . cWorld . lWorld . machines . each . mcType . _McDamSensor . sensAmount) -- <> (fmap show $ u ^.. uvWorld . cWorld . lWorld . machines . each . mcMaterial) --testStringInit u = map show (u ^.. uvWorld . cWorld . lWorld . machines . traverse . mcDir) diff --git a/src/Dodge/WallCreatureCollisions.hs b/src/Dodge/WallCreatureCollisions.hs index edd155320..eb6f84168 100644 --- a/src/Dodge/WallCreatureCollisions.hs +++ b/src/Dodge/WallCreatureCollisions.hs @@ -1,21 +1,15 @@ -- | Deals with moving creature wall collisions. -module Dodge.WallCreatureCollisions ( - colCrsWalls, - colCrWall, - pushCreatureOutFromWalls, - crOnWall, -) where +module Dodge.WallCreatureCollisions (colCrsWalls) where -import qualified Data.IntSet as IS -import Data.Foldable -import Linear -import Dodge.Creature.Radius import Control.Lens -import Data.Monoid +import Data.Foldable +import qualified Data.IntSet as IS import Dodge.Base +import Dodge.Creature.Radius import Dodge.Data.Universe import Dodge.Zoning.Wall import Geometry +import Linear colCrsWalls :: Universe -> Universe colCrsWalls uv = uv & uvWorld . cWorld . lWorld . creatures %~ fmap (noclipCheck (_uvConfig uv) (_uvWorld uv)) @@ -40,9 +34,10 @@ colCrWall w c = cornpush . wallpush $ pushthrough c notff x = x ^. wlMaterial /= ForceField pushCr' :: [Wall] -> Creature -> Creature -pushCr' wls cr - | dist ep sp > r - && dist ep ap > r = ecr & crDamage <>~ [Crushing 1000 0] +pushCr' wls cr + | dist ep sp > r && dist ep ap > r = + ecr + & crDamage <>~ [Crushing 1000 0] & crPos . _xy .~ ap | otherwise = ecr where @@ -59,45 +54,6 @@ pushCr' wls cr wallBuffer :: Float wallBuffer = 0 -pushCreatureOutFromWalls :: [(Point2, Point2)] -> Creature -> Creature -pushCreatureOutFromWalls ls cr = cr & crPos . _xy - %~ pushOutFromWalls (crRad (cr ^. crType)) ls - --- the following tests whether or not a point is on a wall, and if so pushes it --- out from the wall --- this is then repeated if the point ends up on a new wall -pushOutFromWalls :: Float -> [(Point2, Point2)] -> Point2 -> Point2 -pushOutFromWalls rad wls p1 = case (getFirst . foldMap (First . pushOutFromWall rad p1)) wls of - Nothing -> p1 - Just p2 -> pushOutFromWalls rad (tail wls) p2 - ---wallPushList :: Float -> [Wall] -> Point2 -> [(Point2, Wall)] ---wallPushList rad wls p1 = mapMaybe f wls --- where --- f :: Wall -> Maybe (Point2,Wall) --- f wl = case pushOutFromWall rad p1 (wl ^. wlLine) of --- Nothing -> Nothing --- Just p -> Just (p,wl) - --- possible improvement: choose between the closer of p2 and "p3" to p1 - ---pushOutFromWalls' :: Float -> [(Point2,Point2)] -> Point2 -> Point2 ---pushOutFromWalls' rad wls p1 = case (getFirst . foldMap (First . pushOutFromWall' rad p1)) wls of --- Nothing -> p1 --- Just p2 -> fromMaybe p2 $ (getLast . foldMap (Last . pushOutFromWall' rad p2)) wls --- -- possible improvement: choose between the closer of p2 and "p3" to p1 - --- note the inclusion of endpoints in circOnSeg -crOnWall :: Creature -> World -> Bool -crOnWall cr = - any (uncurry (circOnSeg p r) . _wlLine) - . filter notff - . wlsNearCirc p r - where - notff x = x ^. wlMaterial /= ForceField - p = cr ^. crPos . _xy - r = crRad (cr ^. crType) - -- assumes that the wall is orientated -- assumes wall points are different pushOutFromWall :: Float -> Point2 -> (Point2, Point2) -> Maybe Point2 @@ -112,7 +68,6 @@ pushOutFromWall rad cp2 (wp1, wp2) isOnWall = circOnSegNoEndpoints wp1 wp2 cp2 rad pushOutFromCorners :: Float -> [(Point2, Point2)] -> Point2 -> Point2 ---pushOutFromCorners r ls p = foldr (squashIntersectCirclePoint r . fst) p ls pushOutFromCorners r = flip $ foldr (squashIntersectCirclePoint r . fst) squashIntersectCirclePoint :: Float -> Point2 -> Point2 -> Point2