63 lines
2.3 KiB
Haskell
63 lines
2.3 KiB
Haskell
--{-# LANGUAGE TupleSections #-}
|
|
module Dodge.Room.Warning where
|
|
import Dodge.Cleat
|
|
import Dodge.Terminal
|
|
import Dodge.PlacementSpot
|
|
import Dodge.Placement.Instance.Terminal
|
|
import Dodge.Data
|
|
import Dodge.Tree
|
|
import Dodge.Room.Door
|
|
import Dodge.Room.Ngon
|
|
import Dodge.Room.Procedural
|
|
import Dodge.Room.Tanks
|
|
import Dodge.Room.Link
|
|
import Dodge.Placement.Instance
|
|
import Geometry
|
|
import Color
|
|
import LensHelp
|
|
import RandomHelp
|
|
|
|
--import qualified Data.Set as S
|
|
import Data.Maybe
|
|
import qualified Data.Map.Strict as M
|
|
--import Data.Char
|
|
--import Data.Tree
|
|
--import qualified Data.Text as T
|
|
|
|
|
|
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)
|
|
& tmScrollCommands .:~ toggleCommand
|
|
& tmToggles .~ M.fromList
|
|
[("DOOR",TerminalToggle (fromJust $ _plMID trpl) (const (const True)))]
|
|
|
|
moveToSideFirstOutLink :: RoomPos -> Room -> Maybe (Point2,Float)
|
|
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)
|
|
-- the above test may not work properly if the room polys are
|
|
-- complicated, it should really use created walls...
|
|
then Just (rtpos, rpdir)
|
|
else Just (ltpos, rpdir)
|
|
_ -> Nothing
|