75 lines
2.9 KiB
Haskell
75 lines
2.9 KiB
Haskell
--{-# LANGUAGE TupleSections #-}
|
|
module Dodge.Room.Warning (warningRooms) where
|
|
|
|
import Dodge.Data.BlBl
|
|
import Color
|
|
import qualified Data.Map.Strict as M
|
|
import Data.Maybe
|
|
import Dodge.Cleat
|
|
import Dodge.Data.GenWorld
|
|
import Dodge.Placement.Instance
|
|
import Dodge.PlacementSpot
|
|
import Dodge.Room.Door
|
|
import Dodge.Room.Link
|
|
import Dodge.Room.Ngon
|
|
import Dodge.Room.Procedural
|
|
import Dodge.Room.Tanks
|
|
import Dodge.Terminal
|
|
import Dodge.Tree
|
|
import Dodge.WorldEffect
|
|
import Geometry
|
|
import LensHelp
|
|
import RandomHelp
|
|
|
|
warningRooms :: RandomGen g => String -> Int -> State g (MetaTree Room String)
|
|
warningRooms str n = do
|
|
rm <- do
|
|
tr <- tanksRoom [] []
|
|
takeOne [roomNgon 8 200, roomRectAutoLinks 200 200, tr]
|
|
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])
|
|
where
|
|
outplace =
|
|
extTrigLitPos
|
|
(atFstLnkOutShiftBy (\(p, a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a)))
|
|
( Just . set plSpot (rprShift moveToSideFirstOutLink)
|
|
. putMessageTerminal terminalColor
|
|
. termMessages
|
|
)
|
|
termMessages trpl =
|
|
lineOutputTerminal (makeColorTermLine red "WARNING" : makeTermPara str)
|
|
& tmCommands .:~ TCToggles
|
|
& tmToggles .~ M.fromList
|
|
[("DOOR", TerminalToggle (fromJust $ _plMID trpl) (BlConst True))]
|
|
|
|
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
|
|
-- 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)
|
|
-- in 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...
|
|
-- Just (rtpos, rpdir)
|
|
-- else Just (ltpos, rpdir)
|
|
-- _ -> Nothing
|