From f28a59e7a3b5a9fb1fb1247b8c1a8abb6c584980 Mon Sep 17 00:00:00 2001 From: justin Date: Fri, 13 Mar 2026 10:02:29 +0000 Subject: [PATCH] Add laser run past rooms --- src/Dodge/Room/LasTurret.hs | 74 +++++++++++++++++++++++++------------ src/Dodge/Room/Path.hs | 53 +++++++++++++++++++------- src/RandomHelp.hs | 5 +++ 3 files changed, 94 insertions(+), 38 deletions(-) diff --git a/src/Dodge/Room/LasTurret.hs b/src/Dodge/Room/LasTurret.hs index a8bee6d12..4683f6d54 100644 --- a/src/Dodge/Room/LasTurret.hs +++ b/src/Dodge/Room/LasTurret.hs @@ -11,6 +11,7 @@ module Dodge.Room.LasTurret ( lasCenRunClose, ) where +import Dodge.Room.Path import Dodge.Room.Procedural import qualified Data.Set as S import Dodge.Cleat @@ -142,8 +143,8 @@ lasCenSensEdge n = do , treePost [door, cleatLabel 0 corridor] ] -lasCenRunClose' :: (RandomGen g) => State g (MetaTree Room String) -lasCenRunClose' = do +lasCenRunClose :: (RandomGen g) => State g (MetaTree Room String) +lasCenRunClose = do thelight <- mntLightLnkCond $ rprBool $ const . isInLnk thelight1 <- mntLightLnkCond $ rprBool $ const . isOutLnk r <- @@ -162,6 +163,7 @@ lasCenRunClose' = do -- <&> rmLinks %~ setOutLinksByType (PolyEdge 7) -- <&> rmLinks %~ tail -- <&> rmLinks %~ setOutLinks (const False) + <&> rmPath %~ addNodesCrossingCirc 0 35 rToOnward "lasCenRunClose" $ return $ cleatOnward r where linkwall f x = heightWallPS @@ -170,41 +172,65 @@ lasCenRunClose' = do inlinkwall = linkwall isInLnk outlinkwall = linkwall isOutLnk -lasCenRunClose :: (RandomGen g) => State g (MetaTree Room String) -lasCenRunClose = do - a <- takeOne [3*pi/2]--,pi/4] +lasCenRunCloseLongCor :: (RandomGen g) => State g (MetaTree Room String) +lasCenRunCloseLongCor = do + (alinks,blinks) <- shufflePair (rlinks,llinks) + a <- takeOne [5*pi/16] + let h = 800 + laspos <- takeOne [V2 (h/2) 80] + ls <- mntLightLnkCond (PS (V2 (h/2) 0) pi) + r <- shuffleLinks =<< + (roomRectAutoLights h 160 + <&> rmPmnts + <>~ [ putLasTurret 0.02 & plSpot .~ PS laspos a + , awall (V2 (h /4) 80) (rotateV (pi/16) <$> rectWH 180 10) + , awall (V2 (3*h/4) 80) (rotateV (pi/16) <$> rectWH 180 10) + , ls + ] + <&> rmLinks %~ setInLinks alinks + <&> rmLinks %~ setOutLinks blinks + <&> rmPath %~ + (addNodesCrossing (V2 (h/2-10) 30,V2 (h/2+50) 90) + .addNodesCrossing (V2 (h/2+10) 130,V2 (h/2-50) 70) ) + ) + rToOnward "lasCenRunClose" $ return $ cleatOnward r + where + llinks = memtest (FromEdge South 1) (OnEdge West) + rlinks = memtest (FromEdge South 1) (OnEdge East) + awall x v = heightWallPS (PS x 0) 30 v + etest f g x = f x || g x + memtest a b x = let y = _rlType x + in a `S.member` y && b `S.member` y + +lasCenRunClose1 :: (RandomGen g) => State g (MetaTree Room String) +lasCenRunClose1 = do + (alinks,blinks) <- shufflePair (bllinks,trlinks) + a <- takeOne [3*pi/2,3*pi/4] laspos <- takeOne [V2 60 190, V2 65 185] r <- shuffleLinks =<< (roomRectAutoLights 250 250 <&> rmPmnts <>~ [ putLasTurret 0.02 & plSpot .~ PS laspos a --- <>~ [ putLasTurret 0.02 & plSpot .~ PS (V2 65 185) 0 --- <>~ [ putLasTurret 0.02 & plSpot .~ PS (V2 70 180) 0 - , awall (V2 35 100) (rectWH 10 60) -- (rectNSWE 80 (-40) (-30) (-10)) - , awall (V2 150 215) (rectWH 60 10) -- (rectNSWE 80 (-40) (-30) (-10)) + , awall (V2 35 100) (rectWH 10 60) + , awall (V2 150 215) (rectWH 60 10) ] - <&> rmLinks %~ setInLinks - (etest - (memtest (FromEdge West 0) (OnEdge South)) - (memtest (FromEdge South 0) (OnEdge West)) - ) - <&> rmLinks %~ setOutLinks - (etest - (memtest (FromEdge East 0) (OnEdge North)) - (memtest (FromEdge North 0) (OnEdge East)) - ) + <&> rmLinks %~ setInLinks alinks + <&> rmLinks %~ setOutLinks blinks + <&> rmPath %~ (addNodesCrossing (V2 110 170,V2 30 250) + .addNodesCrossing (V2 70 150,V2 10 210) ) ) rToOnward "lasCenRunClose" $ return $ cleatOnward r where + bllinks = etest + (memtest (FromEdge West 0) (OnEdge South)) + (memtest (FromEdge South 0) (OnEdge West)) + trlinks = etest + (memtest (FromEdge East 0) (OnEdge North)) + (memtest (FromEdge North 0) (OnEdge East)) awall x v = heightWallPS (PS x 0) 30 v etest f g x = f x || g x memtest a b x = let y = _rlType x in a `S.member` y && b `S.member` y - linkwall f x = heightWallPS - (resetPLUse $ rprBoolShift (const . f) (shiftByV2 x <&> (,S.singleton UsedPosLow))) - 30 - inlinkwall = linkwall isInLnk - outlinkwall = linkwall isOutLnk lasTunnel :: (RandomGen g) => Float -> State g Room lasTunnel y = do diff --git a/src/Dodge/Room/Path.hs b/src/Dodge/Room/Path.hs index a3251144c..8c9074218 100644 --- a/src/Dodge/Room/Path.hs +++ b/src/Dodge/Room/Path.hs @@ -1,31 +1,56 @@ {-# LANGUAGE TupleSections #-} -module Dodge.Room.Path (linksDAGToPath,addNodesCrossing) where -import Linear -import Data.Maybe +module Dodge.Room.Path ( + linksDAGToPath, + addNodesCrossing, + addNodesCrossingCirc, +) where + +import Control.Applicative import Control.Lens import Data.Function (on) import Data.List +import Data.Maybe import qualified Data.Set as S import Dodge.Data.GenWorld import Geometry +import Linear -linksDAGToPath :: Foldable f => [RoomLink] -> f (Point2, Point2) -> S.Set (Point2, Point2) -linksDAGToPath lnks xs - | null xs = foldMap doublePairSet $ ys & each %~ (, centroid ys) +linksDAGToPath :: (Foldable f) => [RoomLink] -> f (Point2, Point2) -> S.Set (Point2, Point2) +linksDAGToPath lnks xs + | null xs = foldMap doublePairSet $ ys & each %~ (,centroid ys) | otherwise = subpth <> foldMap (linkClosest . (^. rlPos)) lnks where ys = lnks <&> _rlPos subpth = foldMap doublePairSet xs linkClosest p = doublePairSet (p, minimumBy (compare `on` dist p) $ S.map fst subpth) -addNodesCrossing :: (Point2,Point2) -> S.Set (Point2,Point2) -> S.Set (Point2,Point2) -addNodesCrossing (x,y) = g . foldMap f +addNodesCrossing :: (Point2, Point2) -> S.Set (Point2, Point2) -> S.Set (Point2, Point2) +addNodesCrossing (x, y) = g . foldMap f where - g (xs,m) = h xs <> m - f (a,b) = fromMaybe (mempty,S.singleton (a,b)) $ do + g (xs, m) = h xs <> m + f (a, b) = fromMaybe (mempty, S.singleton (a, b)) $ do i <- intersectSegSeg x y a b - return (S.singleton i, S.fromList [(a,i),(i,b)]) - h is | null is = mempty - | otherwise = let js = sortOn (distance x) $ S.toList is - in S.fromList . zip js $ tail js + return (S.singleton i, S.fromList [(a, i), (i, b)]) + h is + | null is = mempty + | otherwise = + let js = sortOn (distance x) $ S.toList is + in S.fromList . zip js $ tail js + +addNodesCrossingCirc :: Point2 -> Float -> S.Set (Point2, Point2) -> S.Set (Point2, Point2) +addNodesCrossingCirc c r = g . foldMap f + where + g (xs, m) = h xs <> m + f (a, b) = fromMaybe (mempty, S.singleton (a, b)) $ do + let (ma,mb) = intersectCircSeg c r a b + i <- ma <|> mb + return (S.singleton i, S.fromList [(a, i), (i, b)]) + h is + | (j:js) <- sortOn (\x -> argV (x - c)) $ S.toList is + = S.fromList . zip js $ (tail js <> [j]) + | otherwise = mempty +-- | null is = mempty +-- | otherwise = +-- let (j:js) = sortOn (\x -> argV (x - c)) $ S.toList is +-- in S.fromList . zip js $ (tail js <> [j]) diff --git a/src/RandomHelp.hs b/src/RandomHelp.hs index 0f4c6d77b..4c9548625 100644 --- a/src/RandomHelp.hs +++ b/src/RandomHelp.hs @@ -144,3 +144,8 @@ randFromPair :: RandomGen g => Float -> (a,a) -> State g a randFromPair x (l,r) = do y <- state $ randomR (0,1) if x < y then return l else return r + +shufflePair :: RandomGen g => (a,a) -> State g (a,a) +shufflePair (x,y) = do + v <- state $ randomR (0::Float,1) + if v > 0.5 then return (x,y) else return (y,x)