Simplify laser reflection/refraction

src/Dodge/Base/Wall.hs

@@ -13,8 +13,8 @@ wlIsSeeThrough wl = case _wlOpacity wl of
     SeeThrough -> True
     _ -> False
 
-reflDirWall :: Point2 -> Point2 -> Wall -> Float
+reflWall :: Point2 -> Point2 -> Wall -> Float
-reflDirWall sp ep wl = argV (reflectIn (uncurry (-.-) (_wlLine wl)) (ep -.- sp))
+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

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 :) $
+            f
-                reflectLaserAlong
+                p
-                    phasev
+                (p + angle (reflWall sp p wl))
-                    (p +.+ unitVectorAtAngle (reflDirWall sp p wl))
+                (p + distance p ep *^ angle (reflWall sp p wl))
-                    (p +.+ dist p ep *.* unitVectorAtAngle (reflDirWall sp p wl))
-                    w
         | wlIsSeeThrough wl ->
-            second (p :) $
+            f p (p + signorm (refract phasev sp ep wl p)) (refract phasev sp ep wl p)
-                reflectLaserAlong
-                    phasev
-                    (p +.+ normalizeV (refract phasev sp ep wl p))
-                    (refract phasev sp ep wl p)
-                    w
-        | otherwise -> (Just (p, Right 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)
+    | isEntering = p + rotateV angleRef (normalDist wlNormal)
-    | otherwise = p +.+ rotateV angleRef' (normalDist wlNormal')
+    | otherwise = p + rotateV angleRef' (normalDist wlNormal')
   where
     wlNormal = vNormal $ uncurry (-.-) $ swap (_wlLine wl)
     wlNormal' = vNormal $ uncurry (-.-) (_wlLine wl)
@@ -74,22 +70,15 @@ reflectPulseLaserAlong phasev sp ep w = f $ filter (isunshad . snd) $ crWlPbHit
     f = \case
         ((p, OWall wl) : _)
             | Metal <- wl ^. wlMaterial ->
-                second (p :) $
+                g
-                    reflectPulseLaserAlong
+                    p
-                        phasev
+                    (p + angle (reflWall sp p wl))
-                        (p +.+ unitVectorAtAngle (reflDirWall sp p wl))
+                    (p + distance p ep *.* angle (reflWall sp p wl))
-                        (p +.+ dist p ep *.* unitVectorAtAngle (reflDirWall sp p wl))
-                        w
             | wlIsSeeThrough wl ->
-                second (p :) $
+                g p (p + signorm (refract phasev sp ep wl p)) (refract phasev sp ep wl 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])
         [] -> ([], [ep])
     isunshad (OWall wl) = _wlUnshadowed wl
     isunshad _ = True
+    g p a b = reflectPulseLaserAlong phasev a b w & _2 .:~ p

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)
+    x <- state $ randomR (150, 300)
---    y <- state $ randomR (150, 300)
+    y <- state $ randomR (150, 300)
-    x <- return 250
-    y <- return 250
     roomRectAutoLinks x y
         <&> rmLinks %~ setOutLinks (isCornerLink NorthWest)
         <&> rmLinks %~ setInLinks (isCornerLink SouthEast)