Work on laser run past rooms

src/Dodge/Data/Config.hs

@@ -84,7 +84,8 @@ data DebugBool
     | Cr_status
     | Cr_awareness
     | Mouse_position
-    | View_boundaries
+    | View_gr_boundaries
+    | View_rm_boundaries
     | Walls_info
     | Pathing
     | Remove_LOS

src/Dodge/Debug.hs

@@ -57,7 +57,8 @@ debugItem = \case
     Close_shape_culling -> mempty
     Bound_box_screen -> mempty
     Show_ms_frame -> mempty
-    View_boundaries -> mempty
+    View_gr_boundaries -> mempty
+    View_rm_boundaries -> mempty
     Show_bound_box -> mempty
     Show_wall_search_rays -> mempty
     Show_dda_test -> mempty
@@ -227,7 +228,8 @@ drawDebug u = \case
     Close_shape_culling -> mempty
     Bound_box_screen -> mempty
     Show_ms_frame -> mempty
-    View_boundaries -> viewBoundaries $ _uvWorld u
+    View_gr_boundaries -> viewGameRoomBoundaries $ _uvWorld u
+    View_rm_boundaries -> viewRoomBoundaries $ _uvWorld u
     Show_bound_box -> drawBoundingBox $ _uvWorld u
     Show_wall_search_rays -> drawWallSearchRays $ _uvWorld u
     Show_dda_test -> drawDDATest $ _uvWorld u

src/Dodge/Debug/Picture.hs

@@ -329,8 +329,8 @@ drawWallSearchRays w = foldMap (f . fst) $ allVisibleWalls w
                 uncurryV translate p (circle 5)
                     <> line [w ^. wCam . camViewFrom, p]
 
-viewBoundaries :: World -> Picture
-viewBoundaries w =
+viewGameRoomBoundaries :: World -> Picture
+viewGameRoomBoundaries w =
     setLayer DebugLayer $
         color green (foldMap (polygonWire . _grBound) grs)
             <> color yellow (foldMap (\q -> line [p, q]) $ getViewpoints p (_cWorld w))
@@ -338,6 +338,15 @@ viewBoundaries w =
     p = w ^. wCam . camViewFrom
     grs = filter (pointInOrOnPolygon p . _grBound) (_cwgGameRooms $ _cwGen $ _cWorld w)
 
+viewRoomBoundaries :: World -> Picture
+viewRoomBoundaries w =
+    setLayer DebugLayer $
+        color green (foldMap (foldMap polygonWire . _grRmBounds) grs)
+--            <> color yellow (foldMap (\q -> line [p, q]) $ getViewpoints p (_cWorld w))
+  where
+    p = w ^. wCam . camViewFrom
+    grs = filter (pointInOrOnPolygon p . _grBound) (_cwgGameRooms $ _cwGen $ _cWorld w)
+
 viewClipBounds :: Config -> World -> Picture
 viewClipBounds cfig w
     | _debug_view_clip_bounds cfig == AllRoomClipBoundaries =

src/Dodge/Floor.hs

@@ -24,7 +24,7 @@ initialRoomTree :: State LayoutVars MTRS
 initialRoomTree =
     foldMTRS $
         intersperse
-            (zoom lyGen corDoor)
+            (zoom lyGen doorCor)
             [ intAnno startRoom
             , passthroughLockKeyLists
                     [(sensorRoomRunPast ElectricSensor, takeOne 

src/Dodge/GameRoom.hs

@@ -13,6 +13,7 @@ data GameRoom = GameRoom
     { _grViewpoints :: [Point2]
     , _grViewpointsEx :: [Point2]
     , _grBound :: [Point2]
+    , _grRmBounds :: [[Point2]]
     , -- | gives direction of room
       _grDir :: Float
     , _grLinkDirs :: [Float]

src/Dodge/HeldUse.hs

@@ -1159,7 +1159,8 @@ mcShootLaser _ mc =
     shootLaser (MachinePrimarySound (_mcID mc)) (DamageLaser 11) 1 pos dir yellow
   where
     pos = _mcPos mc +.+ 20 *.* unitVectorAtAngle dir
-    dir = mc ^?! mcType . mctTurret . tuDir
+    dir = (mc ^?! mcType . mctTurret . tuDir)
+        + mc ^. mcDir
 
 mcShootAuto :: Item -> Machine -> World -> World
 mcShootAuto itm mc w

src/Dodge/Item/HeldOffset.hs

@@ -21,7 +21,7 @@ import qualified Quaternion as Q
 
 turretItemOffset :: Item -> Turret -> Machine -> Point3 -> Point3
 turretItemOffset it tu mc =
-    rotate3 (_tuDir tu - _mcDir mc) . (+.+.+ V3 0 0 shoulderHeight)
+    rotate3 (_tuDir tu + _mcDir mc) . (+.+.+ V3 0 0 shoulderHeight)
         . transToHandle it
 
 transToHandle :: Item -> Point3 -> Point3

src/Dodge/Layout.hs

@@ -162,6 +162,7 @@ gameRoomFromRoom rm =
                 expandPolyCorners 50 . convexHullSafe . nubBy closePoints
                     . concat
                     $ _rmBound rm ++ _rmPolys rm
+        , _grRmBounds = map (map doshift) $ _rmBound rm
         , _grDir = getDir $ _rmPos rm
         , _grLinkDirs = mapMaybe undir $ _rmPos rm
         , _grName = _rmName rm

src/Dodge/Machine/Update.hs

@@ -85,6 +85,7 @@ updateTurret rotSpeed mc w =
 --    (elecDams, dams) = partition isElectrical $ _mcDamage mc
 --    dam = sum $ map _dmAmount dams
 --    elecDam = sum $ map _dmAmount elecDams
+    mcdir = _mcDir mc
     doTurn
         | seesYou =
             cWorld
@@ -94,7 +95,7 @@ updateTurret rotSpeed mc w =
                 . mcType
                 . mctTurret
                 . tuDir
-                %~ turnTo rotSpeed mcpos ypos
+                %~ ((subtract mcdir) . turnTo rotSpeed mcpos ypos . (+mcdir))
         | otherwise = id
     closeFireAngle = seesYou -- && angleVV (ypos -.- mcpos) (unitVectorAtAngle mcdir) < 1
     updateFiringStatus

src/Dodge/Material/Damage.hs

@@ -30,9 +30,12 @@ damMatSideEffect dm = \case
 defDamageMaterial :: Damage -> ECW -> World -> (Int,World)
 defDamageMaterial dm _ = (dm ^. dmAmount,)
 
+laserSpark x y -- = makeSpark FireSpark x y
+    = id
+
 damageStone :: Damage -> ECW -> World -> (Int,World)
 damageStone dm ecw w = case dm of
-        Lasering _ p t -> f 0 $ makeSpark FireSpark (outTo p t) (rdir p t)
+        Lasering _ p t -> f 0 $ laserSpark (outTo p t) (rdir p t)
         Piercing _ p t -> 
             f dmam $ makeSpark NormalSpark (outTo p t) (rdir p t)
                 . makeDustAt Stone 200 (addZ 20 (outTo p t))
@@ -64,7 +67,7 @@ damageStone dm ecw w = case dm of
 
 damageMetal :: Damage -> ECW -> World -> (Int,World)
 damageMetal dm ecw w = case dm of
-        Lasering _ p t -> f 0 $ makeSpark FireSpark (outTo p t) (rdir p t)
+        Lasering _ p t -> f 0 $ laserSpark (outTo p t) (rdir p t)
         Piercing _ p t -> f dmam $
             makeSpark NormalSpark (outTo p t) (rdir p t)
                 . randsound p [tingS, ting1S, ting2S, ting3S, ting4S, ting5S]

src/Dodge/Room/Corridor.hs

@@ -20,10 +20,11 @@ corridor =
         { _rmPolys = [poly]
         , _rmLinks = lnks'
         , --, _rmPath  = foldMap (doublePairSet . (,) (V2 20 60) . fst) lnks
-          _rmPath = foldMap (doublePairSet . (,) (V2 20 60)) [V2 20 70, V2 20 10]
+          _rmPath = foldMap (doublePairSet . (,) (V2 20 60)) [V2 20 70, V2 20 5]
         --, _rmPmnts = [spanLightI (V2 0 39.5) (V2 40 39.5)]
         , _rmPmnts = []
-        , _rmBound = [rectNSWE 50 30 (-5) 45]
+--        , _rmBound = [rectNSWE 45 35 (-5) 45]
+        , _rmBound = [rectNSWE 60 15 (-5) 45]
         , _rmFloor = Tiled [makeTileFromPoly poly 5]
         , _rmRandPSs = [psRandRanges (10, 30) (30, 60) (0, 2 * pi)]
         , _rmName = "Corridor"
@@ -38,7 +39,7 @@ corridor =
         , outLink (V2 20 70) (negate $ pi / 4)
         , outLink (V2 20 70) (pi / 6)
         , outLink (V2 20 70) (negate $ pi / 6)
-        , inLink (V2 20 10) pi
+        , inLink (V2 20 5) pi
         ]
 
 keyholeCorridor :: Room

src/Dodge/Room/Door.hs

@@ -19,6 +19,7 @@ door =
         , -- door extends into side walls (for shadows as rendered 12/03)
           _rmPmnts = [putAutoDoor (V2 0 20) (V2 40 20)]
         , _rmName = "autoDoor"
+--        , _rmBound = [rectNSWE 21 19 0 40]
         , _rmBound = [rectNSWE 21 19 0 40]
         }
   where

src/Dodge/Room/LasTurret.hs

@@ -9,8 +9,14 @@ module Dodge.Room.LasTurret (
     lasSensorTurretTest,
     healthTest,
     lasCenRunClose,
+    lasCenRunClose',
+    lasCenRunClose1,
+    lasCenRunCloseLongCor,
 ) where
 
+import Data.Foldable (fold)
+import Dodge.Room.Path
+import Dodge.Room.Procedural
 import qualified Data.Set as S
 import Dodge.Cleat
 import Dodge.Data.GenWorld
@@ -143,32 +149,198 @@ lasCenSensEdge n = do
 
 lasCenRunClose :: (RandomGen g) => State g (MetaTree Room String)
 lasCenRunClose = do
+    npoly <- takeOne [6,8,10,12]
     thelight <- mntLightLnkCond $ rprBool $ const . isInLnk
     thelight1 <- mntLightLnkCond $ rprBool $ const . isOutLnk
-    r <-
-        roomNgon 8 250
+    thelight2 <- mntLightLnkCond $ rprBool $ const . (\rp -> PolyEdge ((npoly + 1) `div` 4) `S.member` 
+        (fold $ rp ^? rpType . rplsType))
+    thelight3 <- mntLightLnkCond $ rprBool $ const . (\rp -> PolyEdge (3*(npoly + 1) `div` 4) `S.member` 
+        (fold $ rp ^? rpType . rplsType))
+--    thelight3 <- mntLightLnkCond $ rprBool $ const . isOutLnk
+    r <- shuffleLinks =<<
+        (roomNgon npoly 250
             <&> rmPmnts
-            .~ [ putLasTurret 0.02
-               , inlinkwall 70 (rectNSWE 10 (-10) (-10) 30)
-               , inlinkwall 125 (rectNSWE 55 (-55) (-10) 10)
-               , inlinkwall 180 (rectNSWE 10 (-10) (-30) 10)
-               , outlinkwall 70 (rectNSWE 10 (-10) (-30) 10)
-               , outlinkwall 125 (rectNSWE 55 (-55) (-10) 10)
-               , outlinkwall 180 (rectNSWE 10 (-10) (-10) 30)
+            .~ 
+                [angwall a | a <- [0,pi/8..pi-pi/9]] <>
+                [bngwall a | a <- [0,pi/8..pi-pi/9]] <>
+                [ putLasTurret 0.02
+--                , awall (V2 0 50) (square 10)
+               , thelight
+               , thelight1
+                , thelight2
+                , thelight3
+               ]
+            <&> rmPath %~ (addNodesCrossingCirc 0 30
+                    . flip (foldr ($)) [apath a | a <- [0,pi/8..pi-2*pi/9]]
+                    . flip (foldr ($)) [bpath a | a <- [0,pi/8..pi-2*pi/9]]
+                    )
+            <&> rmLinks %~ setInLinksByType (PolyEdge 0)
+            <&> rmLinks %~ setOutLinksByType (PolyEdge (npoly `div` 2))
+        )
+    rToOnward "lasCenRunClose" $ return $ cleatOnward r
+  where
+    awall x v = heightWallPS (PS x 0) 30 v
+    --angwall a = awall (V2 0 100 + rotateV a (V2 0 100)) (fmap (rotateV (pi/4 + a/2)) $ rectWH 5 (25 - a*10/pi ))
+    angwall a = awall (V2 0 100 + rotateV a (V2 0 100)) (fmap (rotateV (pi/4 + a*0.8)) $ rectWH 5 (23 - a*13/pi ))
+    apath a' = addNodesCrossing $ (\x -> (x + f (V2 0 100),x - f (V2 0 100))) (V2 0 100 + rotateV a (V2 0 100))
+      where
+        a = a' + pi/16
+        f = rotateV (pi/4 + a *0.8)
+    bngwall a = awall (V2 0 (-100) + rotateV a (V2 0 (-100))) (fmap (rotateV (pi/4 + a*0.8)) $ rectWH 5 (23 - a*13/pi ))
+    bpath a' = addNodesCrossing $ (\x -> (x + f (V2 0 100),x - f (V2 0 100))) (V2 0 (-100) + rotateV a (V2 0 (-100)))
+      where
+        a = a' + pi/16
+        f = rotateV (pi/4 + a *0.8)
+
+lasCenRunClose' :: (RandomGen g) => State g (MetaTree Room String)
+lasCenRunClose' = do
+    npoly <- takeOne [5..12]
+    inwall <- takeOne obwalls
+    outwall <- takeOne obwalls
+    thelight <- mntLightLnkCond $ rprBool $ const . isInLnk
+    thelight1 <- mntLightLnkCond $ rprBool $ const . isOutLnk
+    r <- shuffleLinks =<<
+        (roomNgon npoly 250
+            <&> rmPmnts
+            .~ (
+                 fmap (uncurry inlinkwall) inwall <>
+                 fmap (uncurry outlinkwall) outwall <>
+                [ putLasTurret 0.02
                , thelight
                , thelight1
                ]
---            <&> rmLinks %~ setOutLinksByType (PolyEdge 7)
---            <&> rmLinks %~ tail
---            <&> rmLinks %~ setOutLinks (const False)
+                )
+            <&> rmPath %~ addNodesCrossingCirc 0 30
+            <&> rmLinks %~ setInLinksByType (PolyEdge 0)
+            <&> rmLinks %~ setOutLinks (\rl -> or [PolyEdge i `S.member` _rlType rl | i <- [2..npoly-2]])
+        )
     rToOnward "lasCenRunClose" $ return $ cleatOnward r
   where
+    swall = [ (70, (rectNSWE 10 (-10) (-10) 30))
+               , (125, (rectNSWE 55 (-55) (-10) 10))
+               , (180, (rectNSWE 10 (-10) (-30) 10))
+                ]
+    zwall = [ (70, (rectNSWE 10 (-10) (-30) 10))
+               , (125, (rectNSWE 55 (-55) (-10) 10))
+               , (180, (rectNSWE 10 (-10) (-10) 30))
+                ]
+    iwall = [ (70, (rectNSWE 10 (-10) (-15) 20))
+               , (180, (rectNSWE 10 (-10) (-30) (-5)))
+                ]
+    jwall = [ (70, (rectNSWE 10 (-10) (-20) 15))
+               , (180, (rectNSWE 10 (-10) 5 30))
+                ]
+    uwall = [ (180, (rectNSWE 10 (-10) (-20) 20)) ]
+    obwalls = [swall,zwall,iwall,jwall,uwall]
     linkwall f x = heightWallPS
                     (resetPLUse $ rprBoolShift (const . f) (shiftInBy x <&> (,S.singleton UsedPosLow)))
                     30
     inlinkwall = linkwall isInLnk
     outlinkwall = linkwall isOutLnk
 
+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,brlinks)
+    (alinks,blinks) <- shufflePair (bllinks,tmllink)
+    outwall <- takeOne [awall (V2 185 25) (rectWH 10 50) 
+               , awall (V2 200 50) (rectWH 50 10) ]
+    r <- roomRectAutoLights 250 200
+            <&> rmPmnts
+            <>~ [ putLasTurret 0.02 & plSpot .~ PS (V2 125 100) 0
+               , awall (V2 65 25) (rectWH 10 50) 
+                , outwall
+               , awall (V2 95 150) (rectWH 10 10) 
+               --, awall (V2 105 150) (rectWH 20 10) 
+               , awall (V2 155 150) (rectWH 10 10) 
+                , sps0 $ putConvexChasm $ rectNSWE 200 110 105 145
+--               , awall (V2 150 215) (rectWH 60 10)
+               ]
+            <&> rmLinks %~ setInLinks alinks
+--            <&> rmLinks %~ setOutLinks (memtest (OnEdge South) (FromEdge West 3))
+            <&> rmLinks %~ setOutLinks blinks
+            <&> rmLinks . each %~ mvlinks
+            <&> rmPath %~ S.map (both %~ mvpath)
+    rToOnward "lasCenRunClose" $ return $ cleatOnward r
+  where
+    mvlinks lnk | tmllink lnk = lnk & rlPos -~ V2 20 0
+        | tmrlink lnk = lnk & rlPos +~ V2 20 0
+        | otherwise = lnk
+    mvpath (V2 x y) | y > 190 , x > 50 , x < 125 = V2 (x- 20) y
+        | y > 190 , x > 125 , x < 200 = V2 (x+ 20) y
+        | otherwise = V2 x y
+    tmllink = memtest (FromEdge West 1) (OnEdge North)
+    tmrlink = memtest (FromEdge West 2) (OnEdge North)
+    bllinks = etest 
+                    (memtest (FromEdge West 0) (OnEdge South))
+                    (memtest (FromEdge South 0) (OnEdge West))
+    brlinks = etest
+                    (memtest (FromEdge East 0) (OnEdge South))
+                    (memtest (FromEdge South 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
+
+lasCenRunClose2 :: (RandomGen g) => State g (MetaTree Room String)
+lasCenRunClose2 = 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
+               , awall (V2 35 100) (rectWH 10 60) 
+               , awall (V2 150 215) (rectWH 60 10)
+               ]
+            <&> 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
+
 lasTunnel :: (RandomGen g) => Float -> State g Room
 lasTunnel y = do
     extraPlmnts <-

src/Dodge/Room/Path.hs

@@ -1,31 +1,52 @@
 {-# 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

src/Dodge/Room/Room.hs

@@ -8,6 +8,7 @@ module Dodge.Room.Room (
     pistolerRoom,
     spawnerRoom,
     corDoor,
+    doorCor,
     weaponBehindPillar,
     critsRoom,
     distributerRoom,
@@ -395,10 +396,16 @@ spawnerRoom = do
     aRoom <- airlock
     return $ treeFromTrunk [aRoom, corridor] $ pure $ cleatOnward roomWithSpawner
 
+doorCor :: RandomGen g => State g (MetaTree Room String)
+doorCor = do
+    cor <- shuffleLinks (cleatOnward corridor) <&> rmPmnts .~ []
+    return $ tToBTree "doorCor" $ treePost [door, cor]
+
 corDoor :: RandomGen g => State g (MetaTree Room String)
 corDoor = do
-    cor <- shuffleLinks (cleatOnward corridor) <&> rmPmnts .~ []
-    return $ tToBTree "corDoor" $ treePost [door, cor]
+    cor <- shuffleLinks corridor <&> rmPmnts .~ []
+--    let cor = corridorN
+    return $ tToBTree "corDoor" $ treePost [cor,cor, cleatOnward door]
 
 critsPillarRoom :: Int -> State LayoutVars Room
 critsPillarRoom i = do
@@ -452,6 +459,8 @@ distributerRoom atype aamount = do
                 )
     return $ r & rmPmnts .:~ store
         & rmInPmnt <>~ [(0,dst),(1,thepipe)]
+        & rmLinks %~ setInLinksByType (OnEdge South)
+        & rmLinks %~ setOutLinks (not . S.member (OnEdge South) . _rlType)
 
 tmDistributeLines :: [TerminalLine]
 tmDistributeLines = [TLine 1 [TerminalLineConst "ATTEMPTING TO DISTRIBUTE MATERIAL..." white] TmDistributeAmmo]

src/Dodge/Room/Tutorial.hs

@@ -52,10 +52,12 @@ tutAnoTree :: State LayoutVars MTRS
 tutAnoTree = do
     foldMTRS
         [ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
+--        , return . tToBTree "door" $ treePost [corridor, cleatOnward door]
         , corDoor
-        , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor)
-        , lasCenRunClose
+--        , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor)
+        , lasCenRunClose1
 --        , passthroughLockKeyLists lockRoomKeyItems itemRooms
+        , tToBTree "door" . return <$> return (cleatOnward door)
         , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor)
 --        , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor)
 --        , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor)
@@ -68,27 +70,27 @@ tutAnoTree = do
 --        , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor)
         , tToBTree "sdr" . return . cleatOnward <$> 
                 (shuffleLinks =<< distributerRoom BulletAmmo 100000)
---        , return $ tToBTree "cor" $ return $ cleatOnward corridor
---        --, tToBTree "sdr" . return . cleatOnward <$> slowDoorRoom
-----        , tToBTree "sr" . return . cleatOnward <$> tanksRoom [] []
---        , return $ tToBTree "door" $ return $ cleatOnward door
---        , return $ tToBTree "cor" $ return $ cleatOnward corridor
---        , tToBTree "sdr" . return . cleatOnward <$> 
---            (shuffleLinks =<< tanksPipesRoom)
---        , return $ tToBTree "cor" $ return $ cleatOnward corridor
---        , return $ tToBTree "cor" $ return $ cleatOnward corridor
---        , return $ tToBTree "cor" $ return $ cleatOnward corridor
-        , return $ tToBTree "cor" $ return $ cleatOnward corridor
-        , return $ tToBTree "cor" $ return $ cleatOnward corridor
-        , return $ tToBTree "cor" $ return $ cleatOnward corridor
-        , return $ tToBTree "door" $ return $ cleatOnward door
-        , tutHub
-        , chasmSpitTerminal
-        , tutLight
-        , tutDrop
-        , return $ tToBTree "cor" $ return $ cleatOnward corridor
-        ----        , AnTree $ pickupTut
-        ----        , AnTree $ weaponTut
+--aaa--        , return $ tToBTree "cor" $ return $ cleatOnward corridor
+--aaa--        --, tToBTree "sdr" . return . cleatOnward <$> slowDoorRoom
+--aaa----        , tToBTree "sr" . return . cleatOnward <$> tanksRoom [] []
+--aaa--        , return $ tToBTree "door" $ return $ cleatOnward door
+--aaa--        , return $ tToBTree "cor" $ return $ cleatOnward corridor
+--aaa--        , tToBTree "sdr" . return . cleatOnward <$> 
+--aaa--            (shuffleLinks =<< tanksPipesRoom)
+--aaa--        , return $ tToBTree "cor" $ return $ cleatOnward corridor
+--aaa--        , return $ tToBTree "cor" $ return $ cleatOnward corridor
+--aaa--        , return $ tToBTree "cor" $ return $ cleatOnward corridor
+--aaa        , return $ tToBTree "cor" $ return $ cleatOnward corridor
+--aaa        , return $ tToBTree "cor" $ return $ cleatOnward corridor
+--aaa        , return $ tToBTree "cor" $ return $ cleatOnward corridor
+--aaa        , return $ tToBTree "door" $ return $ cleatOnward door
+--aaa        , tutHub
+--aaa        , chasmSpitTerminal
+--aaa        , tutLight
+--aaa        , tutDrop
+--aaa        , return $ tToBTree "cor" $ return $ cleatOnward corridor
+--aaa        ----        , AnTree $ pickupTut
+--aaa        ----        , AnTree $ weaponTut
         ]
 
 foldMTRS ::

src/Dodge/RoomLink.hs

@@ -26,7 +26,6 @@ module Dodge.RoomLink (
 
 import Dodge.Base.CardinalPoint
 import Control.Lens
-import Data.List (partition)
 import qualified Data.Set as S
 import Dodge.Data.GenWorld
 import Geometry
@@ -104,12 +103,11 @@ swapInOutLinks = rmLinks %~ map (rlType %~ S.map f)
     f OutLink = InLink
     f x = x
 
-overLnkType :: RoomLinkType -> ([RoomLink] -> [RoomLink]) -> Room -> Room
-overLnkType lt f = rmLinks %~ g
+overLnkType :: RoomLinkType -> (RoomLink -> RoomLink) -> [RoomLink] -> [RoomLink]
+overLnkType lt f = each %~ g
   where
-    g lnks =
-        let (xs, ys) = partition (S.member lt . _rlType) lnks
-         in f xs ++ ys
+    g lnk | lt `S.member` _rlType lnk = f lnk
+        | otherwise = lnk
 
 rlPosDir :: RoomLink -> (Point2, Float)
 rlPosDir rl = (_rlPos rl, _rlDir rl)

src/Dodge/TestString.hs

@@ -32,7 +32,8 @@ import Data.Foldable
 import Data.Monoid
 
 testStringInit :: Universe -> [String]
-testStringInit _ = mempty
+testStringInit _ = []
+--testStringInit u = map show (u ^.. uvWorld . cWorld . lWorld . machines . traverse . mcDir)
 --testStringInit u =  map show
 --    (u ^.. uvWorld . cWorld . lWorld . machines . traverse .mcType . _McDistributer)
 --    <>

src/Dodge/Tree/Shift.hs

@@ -10,6 +10,7 @@ module Dodge.Tree.Shift (
     PosRooms (..),
 ) where
 
+--import Data.Monoid
 import Control.Lens
 import Data.Bifunctor
 import Data.List (delete)
@@ -66,6 +67,9 @@ posRms prs parenti@(parent, _) ((numChild, t@(Node childi _)) : its) tseq = do
       where
         tryChildLinks [] = tryParentLinks ls
         tryChildLinks ((numinlink, il) : ils)
+--            | Just xs <- clipping' = do
+--                putStrLn $ show xs
+--                tryChildLinks ils
             | clipping = tryChildLinks ils
             | otherwise = do
                 putStrLn $ show j ++ "-" ++ show numinlink
@@ -83,6 +87,7 @@ posRms prs parenti@(parent, _) ((numChild, t@(Node childi _)) : its) tseq = do
           where
             newBounds = map pointsToPoly . _rmBound . doRoomShift . fst $ rootLabel shiftedt
             clipping = or (convexPolysOverlap <$> newBounds <*> _prBounds prs)
+--            clipping' = getFirst . foldMap First $ convexPolysOverlapWitness <$> newBounds <*> _prBounds prs
             updateparent rm =
                 _rmLinkEff rm il child numChild outlnk rm
                     & rmLinks %~ delete outlnk

src/Geometry/ConvexPoly.hs

@@ -9,6 +9,7 @@ module Geometry.ConvexPoly (
     --    , centroid
     pointsToPoly,
     convexPolysOverlap,
+    convexPolysOverlapWitness,
 ) where
 
 import Control.Lens
@@ -18,6 +19,7 @@ import Geometry.Data
 import Geometry.Intersect
 import Geometry.Polygon
 import Geometry.Vector
+import Control.Applicative
 
 --import qualified Control.Foldl as L
 data ConvexPoly = ConvexPoly
@@ -48,6 +50,13 @@ convexPolysOverlap cp1 cp2 =
     dist (_cpCen cp1) (_cpCen cp2) < _cpRad cp1 + _cpRad cp2
         && polyPointsOverlap (_cpPoints cp1) (_cpPoints cp2)
 
+-- | Test whether two polygons intersect or if one is contained in the other,
+-- with witness.
+convexPolysOverlapWitness :: ConvexPoly -> ConvexPoly -> Maybe (ConvexPoly, ConvexPoly,String)
+convexPolysOverlapWitness cp1 cp2 
+    | Just s <- polyPointsOverlapWitness (_cpPoints cp1) (_cpPoints cp2) = Just (cp1,cp2,s)
+    | otherwise = Nothing
+
 
 -- | Test whether two polygons intersect or if one is contained in the other.
 polyPointsOverlap :: [Point2] -> [Point2] -> Bool
@@ -57,6 +66,14 @@ polyPointsOverlap (p : ps) (q : qs) =
         || polyPointsIntersect (p : ps) (q : qs)
 polyPointsOverlap _ _ = False
 
+-- | Test whether two polygons intersect or if one is contained in the other.
+polyPointsOverlapWitness :: [Point2] -> [Point2] -> Maybe String
+polyPointsOverlapWitness (p : ps) (q : qs)
+    | pointInPoly p (q : qs) = Just $ "Contained: "<> show p <> " in " <> show (q:qs)
+    | pointInPoly q (p : ps) = Just $ "Contained: "<> show p <> " in " <> show (q:qs)
+    | otherwise = polyPointsIntersectWitness (p : ps) (q : qs)
+polyPointsOverlapWitness _ _ = Nothing
+
 polyPointsIntersect :: [Point2] -> [Point2] -> Bool
 polyPointsIntersect (a : b : xs) ps = go a (a : b : xs) ps
   where
@@ -65,6 +82,14 @@ polyPointsIntersect (a : b : xs) ps = go a (a : b : xs) ps
     go _ _ _ = False
 polyPointsIntersect _ _ = False
 
+polyPointsIntersectWitness :: [Point2] -> [Point2] -> Maybe String
+polyPointsIntersectWitness (a : b : xs) ps = go a (a : b : xs) ps
+  where
+    go x' (a' : b' : xs') ps' = pairPolyPointsIntersectWitness a' b' ps' <|> go x' (b' : xs') ps'
+    go b' [a'] ps' = pairPolyPointsIntersectWitness a' b' ps'
+    go _ _ _ = Nothing
+polyPointsIntersectWitness _ _ = Nothing
+
 pairPolyPointsIntersect :: Point2 -> Point2 -> [Point2] -> Bool
 pairPolyPointsIntersect a' b' (c' : d' : xs') = go c' a' b' (c' : d' : xs')
   where
@@ -73,5 +98,17 @@ pairPolyPointsIntersect a' b' (c' : d' : xs') = go c' a' b' (c' : d' : xs')
     go _ _ _ _ = False
 pairPolyPointsIntersect _ _ _ = False
 
+pairPolyPointsIntersectWitness :: Point2 -> Point2 -> [Point2] -> Maybe String
+pairPolyPointsIntersectWitness a' b' (c' : d' : xs') = go c' a' b' (c' : d' : xs')
+  where
+    go x a b (c : d : xs) 
+        | intersectSegSegTest a b c d = Just $ show a <> " " <> show b <> " " <> show c <> " " <> show d
+        | otherwise = go x a b (d : xs)
+    go d a b [c] 
+        | intersectSegSegTest a b c d = Just $ show a <> " " <> show b <> " " <> show c <> " " <> show d
+        | otherwise = Nothing
+    go _ _ _ _ = Nothing
+pairPolyPointsIntersectWitness _ _ _ = Nothing
+
 makeLenses ''ConvexPoly
 deriveJSON defaultOptions ''ConvexPoly

src/Geometry/Intersect.hs

@@ -139,20 +139,18 @@ intersectSegSegFullTest x y z w =
 
 {- | It is not always necessary to find a point of intersection, sometimes a
  test may suffice.
+This should intersect on endpoints.
 -}
-intersectSegSegTest ::
-    Point2 ->
-    Point2 ->
-    Point2 ->
-    Point2 ->
-    Bool
+intersectSegSegTest :: Point2 -> Point2 -> Point2 -> Point2 -> Bool
 {-# INLINE intersectSegSegTest #-}
 intersectSegSegTest x y z w =
     f x y z w && f z w x y && x /= y && z /= w
   where
-    f a b c d =
-        (not (isRHS a b c) && not (isLHS a b d))
-            || (not (isLHS a b c) && not (isRHS a b d))
+    f a b c d = compareLHS a b c /= compareLHS a b d
+--        (not (isRHS a b c) && not (isLHS a b d))
+--            || (not (isLHS a b c) && not (isRHS a b d))
+--        (isRHS a b c && isLHS a b d)
+--            || (isLHS a b c && isRHS a b d)
 
 intersectSegSegPreTest ::
     Point2 ->

src/Geometry/LHS.hs

@@ -1,6 +1,7 @@
 module Geometry.LHS (
     isLHS,
     isRHS,
+    compareLHS,
 ) where
 
 import Geometry.Data
@@ -26,6 +27,17 @@ isLHS (V2 x y) (V2 x' y') (V2 x'' y'')
     b1 = x'' - x
     b2 = y'' - y
 
+compareLHS :: Point2 -> Point2 -> Point2 -> Ordering
+{-# INLINE compareLHS #-}
+compareLHS (V2 x y) (V2 x' y') (V2 x'' y'')
+    | (x, y) == (x', y') = EQ
+    | otherwise = compare (a1 * b2 - a2 * b1) 0
+  where
+    a1 = x' - x
+    a2 = y' - y
+    b1 = x'' - x
+    b2 = y'' - y
+
 {- | Test whether a point is on the RHS of a line.
  Returns False if the line is of zero length.
 -}

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)