justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Refactor, try to limit dependencies

Browse Source
This commit is contained in:
justin
2022-07-28 00:59:56 +01:00
parent 8aa5c17ab9
commit 160560af5f
418 changed files with 15104 additions and 13342 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Room/Warning.hs
+37 -31
View File
@@ -1,63 +1,69 @@
--{-# LANGUAGE TupleSections #-}
module Dodge.Room.Warning where
import Dodge.WorldEffect
import Color
--import qualified Data.Set as S
import qualified Data.Map.Strict as M
import Data.Maybe
import Dodge.Cleat
import Dodge.Terminal
import Dodge.Data.GenWorld
import Dodge.Placement.Instance
import Dodge.PlacementSpot
import Dodge.Placement.Instance.Terminal
import Dodge.Data
import Dodge.Tree
import Dodge.Room.Door
import Dodge.Room.Link
import Dodge.Room.Ngon
import Dodge.Room.Procedural
import Dodge.Room.Tanks
import Dodge.Room.Link
import Dodge.Placement.Instance
import Dodge.Terminal
import Dodge.Tree
import Dodge.WorldEffect
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]
takeOne [roomNgon 8 200, roomRectAutoLinks 200 200, tr]
cenroom <- shuffleLinks $ addWarningTerminal str n rm
rToOnward "warningRooms" $ treePost [ door, cenroom, triggerDoorRoom n, cleatOnward door]
rToOnward "warningRooms" $ treePost [door, cenroom, triggerDoorRoom n, cleatOnward door]
addWarningTerminal :: String -> Int -> Room -> Room
addWarningTerminal str outplid = (rmName .++~ "warningTerm-")
. (rmOutPmnt .~ [OutPlacement outplace outplid])
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) (BlConst True))]
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) (BlConst True))]
moveToSideFirstOutLink :: RoomPos -> Room -> Maybe (Point2,Float)
moveToSideFirstOutLink :: RoomPos -> Room -> Maybe (Point2, Float)
moveToSideFirstOutLink rp rm = case rp ^? rpLinkStatus . rplsChildNum of
Just 0 ->
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)
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