Add laser run past rooms

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 :: (RandomGen g) => State g (MetaTree Room String)
-lasCenRunClose' = do
+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)
+lasCenRunCloseLongCor :: (RandomGen g) => State g (MetaTree Room String)
-lasCenRunClose = do
+lasCenRunCloseLongCor = do
-    a <- takeOne [3*pi/2]--,pi/4]
+    (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
+               , awall (V2 35 100) (rectWH 10 60) 
---            <>~ [ putLasTurret 0.02 & plSpot .~ PS (V2 70 180) 0
+               , awall (V2 150 215) (rectWH 60 10)
-               , awall (V2 35 100) (rectWH 10 60) --  (rectNSWE 80 (-40) (-30) (-10))
-               , awall (V2 150 215) (rectWH 60 10) --  (rectNSWE 80 (-40) (-30) (-10))
                ]
-            <&> rmLinks %~ setInLinks 
+            <&> rmLinks %~ setInLinks alinks
-                (etest 
+            <&> rmLinks %~ setOutLinks blinks
-                    (memtest (FromEdge West 0) (OnEdge South))
+            <&> rmPath %~ (addNodesCrossing (V2 110 170,V2 30 250) 
-                    (memtest (FromEdge South 0) (OnEdge West))
+                .addNodesCrossing (V2 70 150,V2 10 210) )
-                )
-            <&> rmLinks %~ setOutLinks 
-                (etest
-                    (memtest (FromEdge East 0) (OnEdge North))
-                    (memtest (FromEdge North 0) (OnEdge East))
-                )
         )
     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

@@ -1,31 +1,56 @@
 {-# LANGUAGE TupleSections #-}
-module Dodge.Room.Path (linksDAGToPath,addNodesCrossing) where
 
-import Linear
+module Dodge.Room.Path (
-import Data.Maybe
+    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 :: (Point2, Point2) -> S.Set (Point2, Point2) -> S.Set (Point2, Point2)
-addNodesCrossing (x,y) = g . foldMap f
+addNodesCrossing (x, y) = g . foldMap f
   where
-    g (xs,m) = h xs <> m
+    g (xs, m) = h xs <> m
-    f (a,b) = fromMaybe (mempty,S.singleton (a,b)) $ do
+    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)])
+        return (S.singleton i, S.fromList [(a, i), (i, b)])
-    h is | null is = mempty
+    h is
-         | otherwise = let js = sortOn (distance x) $ S.toList is
+        | null is = mempty
-                in S.fromList . zip js $ tail js
+        | 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

@@ -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)