112 lines
4.2 KiB
Haskell
112 lines
4.2 KiB
Haskell
--{-# LANGUAGE TupleSections #-}
|
|
module Dodge.Room.Warning (
|
|
warningRooms,
|
|
addDoorToggleTerminal,
|
|
addDoorAtNthLinkToggleTerminal,
|
|
) where
|
|
|
|
import Color
|
|
import Control.Monad
|
|
import qualified Data.Map.Strict as M
|
|
import Data.Maybe
|
|
import qualified Data.Set as S
|
|
import Dodge.Cleat
|
|
import Dodge.Data.BlBl
|
|
import Dodge.Data.GenWorld
|
|
import Dodge.Default.Terminal
|
|
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 Geometry
|
|
import LensHelp
|
|
import RandomHelp
|
|
|
|
warningRooms :: String -> Int -> State StdGen (MetaTree Room String)
|
|
warningRooms str n = do
|
|
rm <- do
|
|
join $ takeOne [roomNgon 8 200, roomRectAutoLinks 200 200, tanksRoom [] []]
|
|
cenroom <- shuffleLinks $ addWarningTerminal str n rm
|
|
rToOnward "warningRooms" $ treePost [door, cenroom, triggerDoorRoom n, cleatOnward door]
|
|
|
|
addDoorToggleTerminal :: [TerminalLine] -> Int -> Room -> Room
|
|
addDoorToggleTerminal = addDoorAtNthLinkToggleTerminal 0
|
|
|
|
addDoorAtNthLinkToggleTerminal :: Int -> [TerminalLine] -> Int -> Room -> Room
|
|
addDoorAtNthLinkToggleTerminal j xs i =
|
|
(rmName .++~ "doorToggle-")
|
|
-- . (rmOutPmnt . at i ?~ outplace)
|
|
. (rmPmnts .:~ outplace)
|
|
where
|
|
outplace =
|
|
extTrigLitPos
|
|
(atNthLnkOutShiftBy j (\(p, a) -> ((p +.+ rotateV a (V2 18.5 (-2.5)), a), S.singleton UsedPosLow)))
|
|
( Just . set plSpot (rprShift (moveToSideNthOutLink (S.singleton UsedPosLow) j))
|
|
. putMessageTerminal
|
|
. termMessages
|
|
)
|
|
& plExternalID
|
|
?~ i
|
|
termMessages trpl =
|
|
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 .~ textInputBlurb tls
|
|
|
|
moveToSideNthOutLink :: S.Set UsedPos
|
|
-> Int -> RoomPos -> Room -> Maybe ((Point2, Float), S.Set UsedPos)
|
|
moveToSideNthOutLink xs i rp rm = do
|
|
j <- rp ^? rpType . rplsChildNum
|
|
guard $ i == j
|
|
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), xs)
|
|
else ((ltpos, rpdir), xs)
|
|
|
|
--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
|