Work on placements/room generation

src/Dodge/Room/Warning.hs

@@ -1,6 +1,8 @@
 --{-# LANGUAGE TupleSections #-}
-module Dodge.Room.Warning (warningRooms) where
+module Dodge.Room.Warning (warningRooms,addDoorToggleTerminal
+    , addDoorAtNthLinkToggleTerminal) where
 
+import Control.Monad
 import Dodge.Default.Terminal
 import Dodge.Data.BlBl
 import Color
@@ -29,28 +31,36 @@ warningRooms str n = do
     cenroom <- shuffleLinks $ addWarningTerminal str n rm
     rToOnward "warningRooms" $ treePost [door, cenroom, triggerDoorRoom n, cleatOnward door]
 
-addWarningTerminal :: String -> Int -> Room -> Room
-addWarningTerminal str outplid = (rmName .++~ "warningTerm-")
-        . (rmOutPmnt .~ [OutPlacement outplace outplid])
+addDoorToggleTerminal :: [TerminalLine] -> Int -> Room -> Room
+addDoorToggleTerminal = addDoorAtNthLinkToggleTerminal 0
+
+addDoorAtNthLinkToggleTerminal :: Int -> [TerminalLine] -> Int -> Room -> Room
+addDoorAtNthLinkToggleTerminal j xs i = (rmName .++~ "doorToggle-")
+        . (rmOutPmnt .:~ OutPlacement outplace i)
   where
     outplace =
         extTrigLitPos
-            (atFstLnkOutShiftBy (\(p, a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a)))
-            ( Just . set plSpot (rprShift moveToSideFirstOutLink)
+            (atNthLnkOutShiftBy j  (\(p, a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a)))
+            ( Just . set plSpot (rprShift (moveToSideNthOutLink j))
                 . putMessageTerminal terminalColor
                 . termMessages
             )
     termMessages trpl =
-        lineOutputTerminal (makeColorTermLine red "WARNING" : makeTermPara str)
+        lineOutputTerminal xs --(makeColorTermLine red "WARNING" : makeTermPara str)
             & tmToggles .~ M.fromList
                     [("DOOR", TerminalToggle (fromJust $ _plMID trpl) (BlConst True))]
 
+
+addWarningTerminal :: String -> Int -> Room -> Room
+addWarningTerminal str = addDoorToggleTerminal (makeColorTermLine red "WARNING" : makeTermPara str)
+
 lineOutputTerminal :: [TerminalLine] -> Terminal
 lineOutputTerminal tls = defaultTerminal & tmBootLines .~ connectionBlurbLines tls
 
-moveToSideFirstOutLink :: RoomPos -> Room -> Maybe (Point2, Float)
-moveToSideFirstOutLink rp rm = do
-    0 <- rp ^? rpLinkStatus . rplsChildNum
+moveToSideNthOutLink :: Int -> RoomPos -> Room -> Maybe (Point2, Float)
+moveToSideNthOutLink i rp rm = do
+    j <- rp ^? rpLinkStatus . rplsChildNum
+    guard $ i == j
     let rppos = _rpPos rp
         rpdir = _rpDir rp
         inpos = rppos +.+ rotateV rpdir (V2 0 (-12.5))
@@ -61,6 +71,20 @@ moveToSideFirstOutLink rp rm = do
             -- complicated, it should really use created walls...
                  (rtpos, rpdir)
             else  (ltpos, rpdir)
+
+--moveToSideFirstOutLink :: RoomPos -> Room -> Maybe (Point2, Float)
+--moveToSideFirstOutLink rp rm = do
+--    0 <- rp ^? rpLinkStatus . rplsChildNum
+--    let rppos = _rpPos rp
+--        rpdir = _rpDir rp
+--        inpos = rppos +.+ rotateV rpdir (V2 0 (-12.5))
+--        rtpos = inpos +.+ rotateV rpdir (V2 30 0)
+--        ltpos = inpos +.+ rotateV rpdir (V2 (-30) 0)
+--    return $ if any (isJust . intersectSegPolyFirst inpos ltpos) (_rmPolys rm)
+--            then -- the above test may not work properly if the room polys are
+--            -- complicated, it should really use created walls...
+--                 (rtpos, rpdir)
+--            else  (ltpos, rpdir)
 --moveToSideFirstOutLink rp rm = case rp ^? rpLinkStatus . rplsChildNum of
 --    Just 0 ->
 --        let rppos = _rpPos rp