justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Add laser run past rooms

Browse Source
This commit is contained in:
justin
2026-03-13 10:02:29 +00:00
parent be72daf6d5
commit f28a59e7a3
3 changed files with 94 additions and 38 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Room/LasTurret.hs
+50 -24
View File
@@ -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
src/Dodge/Room/Path.hs
+38 -13
View File
@@ -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 :: (Foldable f) => [RoomLink] -> f (Point2, Point2) -> S.Set (Point2, Point2)
linksDAGToPath lnks xs
| null xs = foldMap doublePairSet $ ys & each %~ (, centroid ys)
| 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])
src/RandomHelp.hs
+5
View File
@@ -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)