From 20042fcf8d16d2a09de1b9daa4ac2f1c641e5a65 Mon Sep 17 00:00:00 2001 From: justin Date: Mon, 27 Oct 2025 19:41:52 +0000 Subject: [PATCH] Simplify laser reflection/refraction --- src/Dodge/Base/Wall.hs | 4 +-- src/Dodge/Item/Weapon/LaserPath.hs | 55 ++++++++++++------------------ src/Dodge/Room/Tutorial.hs | 8 ++--- 3 files changed, 27 insertions(+), 40 deletions(-) diff --git a/src/Dodge/Base/Wall.hs b/src/Dodge/Base/Wall.hs index f3c2f783d..a52c381f7 100644 --- a/src/Dodge/Base/Wall.hs +++ b/src/Dodge/Base/Wall.hs @@ -13,8 +13,8 @@ wlIsSeeThrough wl = case _wlOpacity wl of SeeThrough -> True _ -> False -reflDirWall :: Point2 -> Point2 -> Wall -> Float -reflDirWall sp ep wl = argV (reflectIn (uncurry (-.-) (_wlLine wl)) (ep -.- sp)) +reflWall :: Point2 -> Point2 -> Wall -> Float +reflWall sp ep wl = argV (reflectIn (uncurry (-) (_wlLine wl)) (ep - sp)) -- point free nonsense. 0 for no damping, 1 for full damping reflVelWallDamp :: Float -> Wall -> Point2 -> Point2 diff --git a/src/Dodge/Item/Weapon/LaserPath.hs b/src/Dodge/Item/Weapon/LaserPath.hs index d663c7082..352fef39c 100644 --- a/src/Dodge/Item/Weapon/LaserPath.hs +++ b/src/Dodge/Item/Weapon/LaserPath.hs @@ -1,17 +1,19 @@ {-# LANGUAGE LambdaCase #-} + module Dodge.Item.Weapon.LaserPath ( reflectLaserAlong, reflectPulseLaserAlong, ) where -import Control.Lens -import Dodge.Data.Object import Data.Bifunctor import Data.Tuple import Dodge.Base.Wall +import Dodge.Data.Object import Dodge.Data.World import Dodge.WorldEvent import Geometry +import LensHelp +import Linear -- this needs to be tested with both reflections and refractions reflectLaserAlong :: @@ -24,28 +26,22 @@ reflectLaserAlong :: reflectLaserAlong phasev sp ep w = case thingHitFilt (const True) _wlUnshadowed sp ep w of Just (p, Right wl) | Metal <- wl ^. wlMaterial -> - second (p :) $ - reflectLaserAlong - phasev - (p +.+ unitVectorAtAngle (reflDirWall sp p wl)) - (p +.+ dist p ep *.* unitVectorAtAngle (reflDirWall sp p wl)) - w + f + p + (p + angle (reflWall sp p wl)) + (p + distance p ep *^ angle (reflWall sp p wl)) | wlIsSeeThrough wl -> - second (p :) $ - reflectLaserAlong - phasev - (p +.+ normalizeV (refract phasev sp ep wl p)) - (refract phasev sp ep wl p) - w - | otherwise -> (Just (p, Right wl), [p]) + f p (p + signorm (refract phasev sp ep wl p)) (refract phasev sp ep wl p) Just (p, obj) -> (Just (p, obj), [p]) Nothing -> (Nothing, [ep]) + where + f p a b = reflectLaserAlong phasev a b w & _2 .:~ p refract :: Float -> Point2 -> Point2 -> Wall -> Point2 -> Point2 {-# INLINE refract #-} refract phasev x y wl p - | isEntering = p +.+ rotateV angleRef (normalDist wlNormal) - | otherwise = p +.+ rotateV angleRef' (normalDist wlNormal') + | isEntering = p + rotateV angleRef (normalDist wlNormal) + | otherwise = p + rotateV angleRef' (normalDist wlNormal') where wlNormal = vNormal $ uncurry (-.-) $ swap (_wlLine wl) wlNormal' = vNormal $ uncurry (-.-) (_wlLine wl) @@ -67,29 +63,22 @@ refract phasev x y wl p reflectExternal = 1 < abs (sin angleInc / phasev) -- note can hit multiple pulse balls -reflectPulseLaserAlong :: Float -> Point2 -> Point2 -> World -> ([(Point2,Object)],[Point2]) +reflectPulseLaserAlong :: Float -> Point2 -> Point2 -> World -> ([(Point2, Object)], [Point2]) {-# INLINE reflectPulseLaserAlong #-} reflectPulseLaserAlong phasev sp ep w = f $ filter (isunshad . snd) $ crWlPbHit sp ep w where f = \case ((p, OWall wl) : _) | Metal <- wl ^. wlMaterial -> - second (p :) $ - reflectPulseLaserAlong - phasev - (p +.+ unitVectorAtAngle (reflDirWall sp p wl)) - (p +.+ dist p ep *.* unitVectorAtAngle (reflDirWall sp p wl)) - w + g + p + (p + angle (reflWall sp p wl)) + (p + distance p ep *.* angle (reflWall sp p wl)) | wlIsSeeThrough wl -> - second (p :) $ - reflectPulseLaserAlong - phasev - (p +.+ normalizeV (refract phasev sp ep wl p)) - (refract phasev sp ep wl p) - w - | otherwise -> ([(p, OWall wl)], [p]) - (x@(_,OPulseBall _) : ps ) -> first (x:) $ f ps - ((p, obj):_) -> ([(p, obj)], [p]) + g p (p + signorm (refract phasev sp ep wl p)) (refract phasev sp ep wl p) + (x@(_, OPulseBall _) : ps) -> first (x :) $ f ps + ((p, obj) : _) -> ([(p, obj)], [p]) [] -> ([], [ep]) isunshad (OWall wl) = _wlUnshadowed wl isunshad _ = True + g p a b = reflectPulseLaserAlong phasev a b w & _2 .:~ p diff --git a/src/Dodge/Room/Tutorial.hs b/src/Dodge/Room/Tutorial.hs index 0625481c1..449b2ddf6 100644 --- a/src/Dodge/Room/Tutorial.hs +++ b/src/Dodge/Room/Tutorial.hs @@ -48,7 +48,7 @@ tutAnoTree = do foldMTRS [ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox , corDoor - , tToBTree "cor" . return . cleatOnward <$> (zChasm 25) + , tToBTree "cor" . return . cleatOnward <$> polyChasmC 6 120 -- , tToBTree "x" . return . cleatOnward <$> airlockSimple -- , tToBTree "lastun" . return . cleatOnward <$> tanksRoom [] [] , return $ tToBTree "cor" $ return $ cleatOnward corridor @@ -158,10 +158,8 @@ lChasm = do -- the Float is the width of the bridge zChasm :: Float -> State LayoutVars Room zChasm z = do --- x <- state $ randomR (150, 300) --- y <- state $ randomR (150, 300) - x <- return 250 - y <- return 250 + x <- state $ randomR (150, 300) + y <- state $ randomR (150, 300) roomRectAutoLinks x y <&> rmLinks %~ setOutLinks (isCornerLink NorthWest) <&> rmLinks %~ setInLinks (isCornerLink SouthEast)