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

Work on airlocks

Browse Source
This commit is contained in:
justin
2025-08-23 17:42:36 +01:00
parent f641805845
commit 32d7120177
19 changed files with 380 additions and 334 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data/GenWorld.hs
+5 -7
View File
@@ -110,8 +110,9 @@ data Room = Room
, _rmPos :: [RoomPos]
, _rmPath :: S.Set (Point2, Point2)
, _rmPmnts :: [Placement]
, _rmInPmnt :: [InPlacement]
, _rmOutPmnt :: [OutPlacement]
, _rmInPmnt :: [InPlacement]
-- note that in placements form a list: multiple InPlacements can use the same id
, _rmOutPmnt :: IM.IntMap Placement
, _rmBound :: [[Point2]]
, _rmFloor :: Floor
, _rmName :: String
@@ -128,13 +129,10 @@ data Room = Room
, _rmClusterStatus :: ClusterStatus
}
data OutPlacement = OutPlacement
{ _opPlacement :: Placement
, _opPlacementID :: Int
}
--data OutPlacement = OutPlacement { _opPlacement :: Placement }
data InPlacement = InPlacement
{ _ipPlacement :: [Placement] -> Placement
{ _ipPlacement :: World -> [Placement] -> Placement
, _ipPlacementID :: Int
}
src/Dodge/Default/Wall.hs
+2 -1
View File
@@ -79,7 +79,8 @@ defaultDirtWall =
}
dirtColor :: Color
dirtColor = V4 (150 / 256) (75 / 256) 0 (250 / 256)
dirtColor = dark $ dark orange
--dirtColor = V4 (150 / 256) (75 / 256) 0 (250 / 256)
defaultWindow :: Wall
defaultWindow =
src/Dodge/Layout.hs
+3 -3
View File
@@ -97,7 +97,7 @@ doInPlacements (im, w) =
doRoomInPlacements :: IM.IntMap [Placement] -> GenWorld -> Room -> (GenWorld, Room)
doRoomInPlacements im w rm = foldr f (w, rm) $ _rmInPmnt rm
where
f (InPlacement plf i) (w', r') = fst $ placeSpot (w', r') (plf $ im IM.! i)
f (InPlacement plf i) (w', r') = fst $ placeSpot (w', r') (plf (w' ^. gwWorld) $ im IM.! i)
doOutPlacements :: GenWorld -> (IM.IntMap [Placement], GenWorld)
doOutPlacements w =
@@ -108,9 +108,9 @@ doRoomOutPlacements ::
(IM.IntMap [Placement], GenWorld) ->
Room ->
((IM.IntMap [Placement], GenWorld), Room)
doRoomOutPlacements imw r = foldr f (imw, r) $ _rmOutPmnt r
doRoomOutPlacements imw r = foldr f (imw, r) $ IM.toList $ _rmOutPmnt r
where
f (OutPlacement pl i) ((im, w), rm) =
f (i, pl) ((im, w), rm) =
let ((neww, newrm), plmnts) = placeSpot (w, rm) pl
in ((IM.insert i plmnts im, neww), newrm)
src/Dodge/Placement/PlaceSpot.hs
+2 -1
View File
@@ -26,7 +26,8 @@ import NewInt
import System.Random
-- when placing a placement, we update the world and the room and assign an id
-- to the placement
-- to the placement. This id should be associated with the type of placement and
-- match up with the created id for the object (creature id, flitid id, etc)
placeSpot :: (GenWorld, Room) -> Placement -> ((GenWorld, Room), [Placement])
placeSpot (w, rm) plmnt = case plmnt of
Placement{_plSpot = PSRoomRand i f} -> placeSpotRoomRand rm i f plmnt w
src/Dodge/PlacementSpot.hs
+120 -110
View File
@@ -1,52 +1,51 @@
--{-# LANGUAGE LambdaCase #-}
module Dodge.PlacementSpot
( atFstLnkOut
, atNthLnkOutShiftBy
, rpIsOnPath
, rpIsOffPath
, rpOffPathFromEdge
, rpOnPathFromEdge
, useUnusedLnk
, psRandRanges
, useRoomPosCond
, isUsedLnkUnplaced
, anyUnusedSpot
, unusedSpotAwayFromLink
, isUnusedLnk
, isInLnk
, isOutLnk
, unusedSpotNearInLink
, randDirPS
, unusedSpotAwayFromInLink
, useLnkRoomPos
, atFstLnkOutShiftInward
, atFstLnkOutShiftBy
, atNthLnkOutShiftInward
, unusedOffPathAwayFromLink
, setFallback
, twoRoomPoss
, isUnusedLnkType
, rprBoolShift
, rprShift
, rprBool
, shiftInBy
, resetPLUse
, psposAddLabel
, shiftByV2
, usedRoomLinkPoss
, usedRoomInLinkPoss
, atNthLinkOut
) where
import Dodge.Data.GenWorld
import Geometry
module Dodge.PlacementSpot (
atFstLnkOut,
atNthLnkOutShiftBy,
rpIsOnPath,
rpIsOffPath,
rpOffPathFromEdge,
rpOnPathFromEdge,
useUnusedLnk,
psRandRanges,
useRoomPosCond,
isUsedLnkUnplaced,
anyUnusedSpot,
unusedSpotAwayFromLink,
isUnusedLnk,
isInLnk,
isOutLnk,
unusedSpotNearInLink,
randDirPS,
unusedSpotAwayFromInLink,
useLnkRoomPos,
atFstLnkOutShiftInward,
atFstLnkOutShiftBy,
atNthLnkOutShiftInward,
unusedOffPathAwayFromLink,
setFallback,
twoRoomPoss,
isUnusedLnkType,
rprBoolShift,
rprShift,
rprBool,
shiftInBy,
resetPLUse,
psposAddLabel,
shiftByV2,
usedRoomLinkPoss,
usedRoomInLinkPoss,
atNthLinkOut,
) where
import Control.Lens
import Data.Maybe
import Data.Bifunctor
import Control.Monad.State
import System.Random
import Data.Bifunctor
import Data.Maybe
import qualified Data.Set as S
import Dodge.Data.GenWorld
import Geometry
import System.Random
setDirPS :: Float -> PlacementSpot -> PlacementSpot
setDirPS a ps = case ps of
@@ -57,16 +56,16 @@ setDirPS a ps = case ps of
randDirPS :: RandomGen g => PlacementSpot -> State g PlacementSpot
randDirPS ps = do
a <- state $ randomR (0,pi*2)
a <- state $ randomR (0, pi * 2)
return $ setDirPS a ps
isUnusedLnk :: RoomPos -> Room -> Bool
isUnusedLnk rp _ = case _rpLinkStatus rp of
UnusedLink {} -> _rpPlacementUse rp == 0
UnusedLink{} -> _rpPlacementUse rp == 0
_ -> False
anyUnusedSpot :: PlacementSpot
anyUnusedSpot = rprBool $ \rp _ -> _rpLinkStatus rp == NotLink && _rpPlacementUse rp == 0
anyUnusedSpot = rprBool $ \rp _ -> _rpLinkStatus rp == NotLink && _rpPlacementUse rp == 0
psposAddLabel :: RoomPosType -> PlacementSpot -> PlacementSpot
psposAddLabel lab = psSelect %~ (\f rp r -> f rp r & _Just . _2 . rpType %~ S.insert lab)
@@ -77,23 +76,25 @@ rprBool t = PSPos (useRoomPosRoomCond t) (const id) Nothing
rpIsOnPath :: RoomPos -> Bool
rpIsOnPath = any f . _rpType
where
f RoomPosOnPath {} = True
f RoomPosOnPath{} = True
f _ = False
rpIsOffPath :: RoomPos -> Bool
rpIsOffPath = any f . _rpType
where
f RoomPosOffPath {} = True
f RoomPosOffPath{} = True
f _ = False
rpOffPathFromEdge :: PathFromEdge -> RoomPos -> Bool
rpOffPathFromEdge pe = any f . _rpType
where
f rt = maybe False (pe `elem`) (rt ^? offPathFromEdges)
f rt = maybe False (pe `elem`) (rt ^? offPathFromEdges)
-- test whether a roomPos is on the path with a given from edge value
rpOnPathFromEdge :: PathFromEdge -> RoomPos -> Bool
rpOnPathFromEdge pe = any f . _rpType
where
f rt = maybe False (pe `elem`) (rt ^? onPathFromEdges)
f rt = maybe False (pe `elem`) (rt ^? onPathFromEdges)
resetPLUse :: PlacementSpot -> PlacementSpot
resetPLUse (PSPos f g fallback) = PSPos f' g fallback
@@ -101,58 +102,64 @@ resetPLUse (PSPos f g fallback) = PSPos f' g fallback
f' rp = fmap (second (rpPlacementUse .~ 0)) . f rp
resetPLUse _ = error "Tried to reset _rpPlacementUse of non PSPos placement"
rprShift
:: (RoomPos -> Room -> Maybe (Point2,Float))
-> PlacementSpot
rprShift ::
(RoomPos -> Room -> Maybe (Point2, Float)) ->
PlacementSpot
rprShift t = PSPos f (const id) Nothing
where
f rp r = case t rp r of
Just (p,a) -> Just (PS p a, rp & rpPlacementUse +~ 1)
Nothing -> Nothing
Just (p, a) -> Just (PS p a, rp & rpPlacementUse +~ 1)
Nothing -> Nothing
rprBoolShift :: (RoomPos -> Room -> Bool)
-> ((Point2,Float) -> (Point2,Float))
-> PlacementSpot
rprBoolShift ::
(RoomPos -> Room -> Bool) ->
((Point2, Float) -> (Point2, Float)) ->
PlacementSpot
rprBoolShift t shift = PSPos f (const id) Nothing
where
f rp r
| t rp r = Just (PS p a, rp & rpPlacementUse +~ 1)
| t rp r = Just (PS p a, rp & rpPlacementUse +~ 1)
| otherwise = Nothing
where
(p,a) = shift (_rpPos rp, _rpDir rp)
(p, a) = shift (_rpPos rp, _rpDir rp)
unusedSpotAwayFromLink :: Float -> PlacementSpot
unusedSpotAwayFromLink x = rprBool $ \rp r -> _rpLinkStatus rp == NotLink
&& _rpPlacementUse rp == 0
&& all ( (>x) . dist (_rpPos rp) ) (usedRoomLinkPoss r)
unusedSpotAwayFromLink x = rprBool $ \rp r ->
_rpLinkStatus rp == NotLink
&& _rpPlacementUse rp == 0
&& all ((> x) . dist (_rpPos rp)) (usedRoomLinkPoss r)
setFallback :: Placement -> Placement -> Placement
setFallback fallback
= (plSpot . psFallback %~ maybe (Just fallback) Just)
. (plIDCont %~ fmap (fmap (fmap $ setFallback fallback))
)
setFallback fallback =
(plSpot . psFallback %~ maybe (Just fallback) Just)
. ( plIDCont %~ fmap (fmap (fmap $ setFallback fallback))
)
unusedOffPathAwayFromLink :: Float -> PlacementSpot
--unusedOffPathAwayFromLink x = rprBool $ \rp r -> _rpLinkStatus rp == NotLink
unusedOffPathAwayFromLink x = rprBool $ \rp r -> _rpPlacementUse rp == 0
&& all ( (>x) . dist (_rpPos rp) ) (usedRoomLinkPoss r)
&& rpIsOffPath rp
--unusedOffPathAwayFromLink x = rprBool $ \rp r -> _rpLinkStatus rp == NotLink
unusedOffPathAwayFromLink x = rprBool $ \rp r ->
_rpPlacementUse rp == 0
&& all ((> x) . dist (_rpPos rp)) (usedRoomLinkPoss r)
&& rpIsOffPath rp
unusedSpotAwayFromInLink :: Float -> PlacementSpot
unusedSpotAwayFromInLink x = rprBool $ \rp r -> _rpLinkStatus rp == NotLink
&& _rpPlacementUse rp == 0
&& all ( (>x) . dist (_rpPos rp) ) (usedRoomInLinkPoss r)
unusedSpotAwayFromInLink x = rprBool $ \rp r ->
_rpLinkStatus rp == NotLink
&& _rpPlacementUse rp == 0
&& all ((> x) . dist (_rpPos rp)) (usedRoomInLinkPoss r)
--twoUnusedLinks :: (PlacementSpot -> PlacementSpot -> Placement) -> Placement
--twoUnusedLinks = twoRoomPoss isUnusedLnk isUnusedLnk
twoRoomPoss :: (RoomPos -> Room -> Bool)
-> (RoomPos -> Room -> Bool)
-> (PlacementSpot -> PlacementSpot -> Placement)
-> Placement
twoRoomPoss cond1 cond2 f = Placement 10 (rprBool cond1) PutNothing Nothing
$ \_ pl1 -> Just $ Placement 10 (rprBool cond2) PutNothing Nothing
$ \_ pl2 -> Just $ f (_plSpot pl1) (_plSpot pl2)
twoRoomPoss ::
(RoomPos -> Room -> Bool) ->
(RoomPos -> Room -> Bool) ->
(PlacementSpot -> PlacementSpot -> Placement) ->
Placement
twoRoomPoss cond1 cond2 f = Placement 10 (rprBool cond1) PutNothing Nothing $
\_ pl1 -> Just $
Placement 10 (rprBool cond2) PutNothing Nothing $
\_ pl2 -> Just $ f (_plSpot pl1) (_plSpot pl2)
--isUnusedLnk :: RoomPos -> Bool
--isUnusedLnk rp = case _rpLinkStatus rp of
@@ -161,26 +168,27 @@ twoRoomPoss cond1 cond2 f = Placement 10 (rprBool cond1) PutNothing Nothing
isInLnk :: RoomPos -> Bool
isInLnk rp = case _rpLinkStatus rp of
UsedInLink {} -> _rpPlacementUse rp == 0
UsedInLink{} -> _rpPlacementUse rp == 0
_ -> False
isOutLnk :: RoomPos -> Bool
isOutLnk rp = case _rpLinkStatus rp of
UsedOutLink {} -> _rpPlacementUse rp == 0
UsedOutLink{} -> _rpPlacementUse rp == 0
_ -> False
useUnusedLnk :: PlacementSpot
useUnusedLnk = rprBool isUnusedLnk
isUsedLnkUnplaced :: RoomPos -> Bool
isUsedLnkUnplaced rp = case _rpLinkStatus rp of
UsedOutLink {} -> _rpPlacementUse rp == 0
UsedInLink {} -> _rpPlacementUse rp == 0
isUsedLnkUnplaced rp = case _rpLinkStatus rp of
UsedOutLink{} -> _rpPlacementUse rp == 0
UsedInLink{} -> _rpPlacementUse rp == 0
_ -> False
useRoomPosCond :: (RoomPos -> Room -> Bool) -> RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)
useRoomPosCond :: (RoomPos -> Room -> Bool) -> RoomPos -> Room -> Maybe (PlacementSpot, RoomPos)
useRoomPosCond f = useRoomPosRoomCond $ \rp r -> f rp r
useRoomPosRoomCond :: (RoomPos -> Room -> Bool) -> RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)
useRoomPosRoomCond :: (RoomPos -> Room -> Bool) -> RoomPos -> Room -> Maybe (PlacementSpot, RoomPos)
useRoomPosRoomCond t rp r
| t rp r = Just (PS (_rpPos rp) (_rpDir rp), rp & rpPlacementUse +~ 1)
| otherwise = Nothing
@@ -191,23 +199,24 @@ isUnusedLnkType rlt rp _ = case _rpLinkStatus rp of
_ -> False
unusedSpotNearInLink :: Float -> PlacementSpot
unusedSpotNearInLink x = rprBool $ \rp r -> _rpLinkStatus rp == NotLink
&& _rpPlacementUse rp == 0
&& any ( (<x) . dist (_rpPos rp) ) (usedRoomInLinkPoss r)
unusedSpotNearInLink x = rprBool $ \rp r ->
_rpLinkStatus rp == NotLink
&& _rpPlacementUse rp == 0
&& any ((< x) . dist (_rpPos rp)) (usedRoomInLinkPoss r)
usedRoomInLinkPoss :: Room -> [Point2]
usedRoomInLinkPoss r = mapMaybe f $ _rmPos r
where
f rp = case _rpLinkStatus rp of
UsedInLink {} -> Just $ _rpPos rp
UsedInLink{} -> Just $ _rpPos rp
_ -> Nothing
usedRoomLinkPoss :: Room -> [Point2]
usedRoomLinkPoss r = mapMaybe f $ _rmPos r
where
f rp = case _rpLinkStatus rp of
UsedInLink {} -> Just $ _rpPos rp
UsedOutLink {} -> Just $ _rpPos rp
UsedInLink{} -> Just $ _rpPos rp
UsedOutLink{} -> Just $ _rpPos rp
_ -> Nothing
atFstLnkOut :: PlacementSpot
@@ -216,44 +225,45 @@ atFstLnkOut = atNthLinkOut 0
atNthLinkOut :: Int -> PlacementSpot
atNthLinkOut n = rprBool $ \rp _ -> rp ^? rpLinkStatus . rplsChildNum == Just n
atNthLnkOutShiftBy :: Int -> ((Point2,Float) -> (Point2,Float)) -> PlacementSpot
atNthLnkOutShiftBy n = rprBoolShift
$ \ rp _ -> rp ^? rpLinkStatus . rplsChildNum == Just n
atNthLnkOutShiftBy :: Int -> ((Point2, Float) -> (Point2, Float)) -> PlacementSpot
atNthLnkOutShiftBy n = rprBoolShift $
\rp _ -> rp ^? rpLinkStatus . rplsChildNum == Just n
--atNthLnkOutShiftBy n theshift = PSPos f (const id) Nothing
-- where
-- f rp _ = case _rpLinkStatus rp of
-- UsedOutLink {_rplsChildNum = i} | i == n
-- UsedOutLink {_rplsChildNum = i} | i == n
-- -> Just (PS p a, rp & rpPlacementUse +~ 1)
-- _ -> Nothing
-- where
-- (p,a) = theshift (_rpPos rp,_rpDir rp)
atFstLnkOutShiftBy :: ((Point2,Float) -> (Point2,Float)) -> PlacementSpot
atFstLnkOutShiftBy :: ((Point2, Float) -> (Point2, Float)) -> PlacementSpot
atFstLnkOutShiftBy = atNthLnkOutShiftBy 0
atFstLnkOutShiftInward :: Float -> PlacementSpot
atFstLnkOutShiftInward = atNthLnkOutShiftInward 0
atNthLnkOutShiftInward :: Int -> Float -> PlacementSpot
atNthLnkOutShiftInward n x = atNthLnkOutShiftBy n
$ \ (p,a) -> (p +.+ rotateV a (V2 0 (negate x)),a)
atNthLnkOutShiftInward n x = atNthLnkOutShiftBy n $
\(p, a) -> (p +.+ rotateV a (V2 0 (negate x)), a)
shiftInBy :: Float -> (Point2,Float) -> (Point2,Float)
shiftInBy x (p,a) = (p +.+ rotateV a (V2 0 (negate x)),a)
shiftInBy :: Float -> (Point2, Float) -> (Point2, Float)
shiftInBy x (p, a) = (p +.+ rotateV a (V2 0 (negate x)), a)
shiftByV2 :: Point2 -> (Point2,Float) -> (Point2,Float)
shiftByV2 x (p,a) = (p +.+ rotateV a x,a)
shiftByV2 :: Point2 -> (Point2, Float) -> (Point2, Float)
shiftByV2 x (p, a) = (p +.+ rotateV a x, a)
-- this should probably check the placement use, but so should others: should
-- unify these
useLnkRoomPos :: RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)
useLnkRoomPos :: RoomPos -> Room -> Maybe (PlacementSpot, RoomPos)
useLnkRoomPos rp _ = case _rpLinkStatus rp of
UnusedLink {} -> Just (PS (_rpPos rp) (_rpDir rp) , rp & rpPlacementUse +~ 1)
UnusedLink{} -> Just (PS (_rpPos rp) (_rpDir rp), rp & rpPlacementUse +~ 1)
_ -> Nothing
psRandRanges :: (Float,Float) -> (Float,Float) -> (Float,Float) -> State StdGen (Point2,Float)
psRandRanges :: (Float, Float) -> (Float, Float) -> (Float, Float) -> State StdGen (Point2, Float)
psRandRanges xranges yranges aranges = do
x <- state $ randomR xranges
y <- state $ randomR yranges
a <- state $ randomR aranges
return (V2 x y,a)
return (V2 x y, a)
src/Dodge/Room/Airlock.hs
+26 -1
View File
@@ -3,6 +3,7 @@
{- Rooms that contain two doors and a switch alternating both. -}
module Dodge.Room.Airlock where
import Dodge.Annotation.Data
import Dodge.Data.GenWorld
import Dodge.Default.Door
import Dodge.Default.Room
@@ -14,12 +15,36 @@ import Dodge.RoomLink
import Geometry
import Picture
import RandomHelp
import Control.Lens
-- | A passage with a switch that opens forward access while closing backwards access.
airlock :: RandomGen g => State g Room
airlock = takeOne [airlock0, airlock90, airlockCrystal, airlockZ]
--airlock = takeOne [airlockCrystal]
decontamRoom :: State LayoutVars Room
decontamRoom = do
return $ defaultRoom
& rmPolys .~ [rectNSWE 100 0 0 40, switchcut]
& rmLinks .~ muout lnks ++ muin [last lnks]
& rmPath .~ foldMap doublePairSet [(V2 20 95, V2 20 45), (V2 20 45, V2 20 5)]
& rmPmnts .~
[ pContID (PS (V2 (-35) 50) (negate $ pi / 2)) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect) $
\btid -> Just $
putDoubleDoorThen DoorObstacle thewall (WdBlNegate $ WdBlBtOn btid) 1 (V2 0 20) (V2 40 20) 2 $
\_ _ -> Just $ putDoubleDoor DoorObstacle thewall (WdBlBtOn btid) (V2 0 80) (V2 40 80) 2
, invisibleWall $ rectNSWE 60 40 (-40) (-30)
, spanLightI (V2 (-2) 30) (V2 (-2) 70)
]
& rmBound .~ [rectNSWE 75 15 0 40, switchcut]
where
thewall = switchWallCol col
switchcut = rectNSWE 65 35 (-40) 80
lnks =
[ (V2 20 95, 0)
, (V2 20 5, pi)
]
col = dim $ dim $ bright red
-- | Straight airlock
airlock0 :: Room
@@ -124,7 +149,7 @@ airlock90 =
defaultRoom
{ _rmPolys =
[ rectNSWE 100 10 10 100
, rectNSWE 20 0 20 60
, rectNSWE 20 (-0.1) 20 60
, rectNSWE 20 60 20 0
, map
toV2
src/Dodge/Room/Door.hs
+2 -2
View File
@@ -39,6 +39,6 @@ triggerDoorRoom inplid =
-- note no bounds
}
where
f (pmnt : _) = putDoubleDoor DoorObstacle (switchWallCol red) (cond pmnt) (V2 0 20) (V2 40 20) 2
f _ = error "tried to put a door using an empty placement list"
f _ (pmnt : _) = putDoubleDoor DoorObstacle (switchWallCol red) (cond pmnt) (V2 0 20) (V2 40 20) 2
f _ _ = error "tried to put a door using an empty placement list"
cond pmnt = WdTrig $ fromJust (_plMID pmnt)
src/Dodge/Room/LasTurret.hs
+7 -9
View File
@@ -35,24 +35,24 @@ cenLasTur =
covershape = rectNSWE 10 (-10) (-20) 20
lightSensInsideDoor :: Int -> Room -> Room
lightSensInsideDoor outplid rm =
lightSensInsideDoor i rm =
rm
& rmPmnts
.++~ [ psPt atFstLnkOut (PutForeground $ floorWire (V2 20 0) (V2 20 (-100)))
, psPt atFstLnkOut (PutForeground $ floorWire (V2 0 (-100)) (V2 20 (-100)))
, psPt atFstLnkOut (PutForeground $ verticalWire (V2 20 0) 0 80)
]
& rmOutPmnt .~ [OutPlacement (sensAboveDoor LaserSensor 10 (atFstLnkOutShiftInward 100)) outplid]
& rmOutPmnt . at i ?~ (sensAboveDoor LaserSensor 10 (atFstLnkOutShiftInward 100))
lightSensByDoor :: Int -> Room -> Room
lightSensByDoor outplid rm =
lightSensByDoor i rm =
rm
& rmPmnts
.++~ [ psPt atFstLnkOut $ PutForeground $ verticalWire (V2 20 0) 0 80
, heightWallPS (atNthLnkOutShiftInward 1 100) 30 covershape
, heightWallPS (atFstLnkOutShiftInward 100) 30 covershape
]
& rmOutPmnt .~ [OutPlacement (sensAboveDoor LaserSensor 20 (atFstLnkOutShiftBy sensorshift)) outplid]
& rmOutPmnt . at i ?~ (sensAboveDoor LaserSensor 20 (atFstLnkOutShiftBy sensorshift))
where
covershape = rectNSWE 10 (-10) (-20) 20
sensorshift (p, a) = (p +.+ rotateV a (V2 60 (-20)), a)
@@ -76,21 +76,19 @@ healthAnalyserByDoor :: Int -> Room -> Room
healthAnalyserByDoor = analyserByDoor (RequireHealth 1100)
analyserByNthLink :: Int -> ProximityRequirement -> Int -> Room -> Room
analyserByNthLink n proxreq outplid rm =
analyserByNthLink n proxreq i rm =
rm
& rmPmnts
.++~ [ psPt (atNthLinkOut n) $ PutForeground $ verticalWire (V2 20 0) 0 80
]
& rmOutPmnt
.:~ OutPlacement
& rmOutPmnt . at i ?~
( analyser
proxreq
(atNthLnkOutShiftBy n (\(p, a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a)))
(atNthLnkOutShiftBy n sensorshift)
)
outplid
where
sensorshift (p, a) = (p +.+ rotateV a (V2 30 (-10)), a)
sensorshift (p, a) = (p +.+ rotateV a (V2 (-30) (-10)), a)
analyserByDoor :: ProximityRequirement -> Int -> Room -> Room
analyserByDoor = analyserByNthLink 0
src/Dodge/Room/RoadBlock.hs
+1 -1
View File
@@ -61,7 +61,7 @@ longBlockedCorridor maxn = do
n <- state $ randomR (0, maxn)
let plmnts =
[ sPS (V2 20 40) r $ dirtPoly $ square 10
, sPS (V2 20 15) 0 putLamp
-- , sPS (V2 20 15) 0 putLamp
]
sequence $
treeFromPost (replicate n $ shuffleLinks corridor) $
src/Dodge/Room/RunPast.hs
+2 -1
View File
@@ -2,6 +2,7 @@ module Dodge.Room.RunPast (
lockedStart,
) where
import qualified Data.IntMap.Strict as IM
import Color
import qualified Data.Set as S
import Dodge.Cleat
@@ -50,7 +51,7 @@ lockedStart i = do
map (over root $ rmConnectsTo .~ S.member theedge) doorrooms
++ [ return
smallRoom
{ _rmOutPmnt = [OutPlacement (putLitButOnPosExtTrig red useUnusedLnk) i]
{ _rmOutPmnt = IM.singleton i (putLitButOnPosExtTrig red useUnusedLnk)
, _rmPmnts = [plRRpt 0 (PutFlIt theweapon)]
, _rmBound = [rectNSWE 70 30 0 40]
}
src/Dodge/Room/SensorDoor.hs
+2 -2
View File
@@ -56,7 +56,7 @@ sensAboveDoor sensetype wth ps =
(\tp -> Just $ damageSensor sensetype wth (_plMID tp) ps)
sensInsideDoor :: SensorType -> Int -> Room -> Room
sensInsideDoor senseType outplid rm = rm
sensInsideDoor senseType i rm = rm
& rmName .++~ take 4 (show senseType)
& rmPmnts
.++~ [ psPt atFstLnkOut . PutForeground $ floorWire (V2 20 0) (V2 20 (-100))
@@ -66,4 +66,4 @@ sensInsideDoor senseType outplid rm = rm
(textTerminal & tmCommands .:~ TCDamageCommand)
& plSpot .~ rprBoolShift isUnusedLnk (shiftInBy 10)
]
& rmOutPmnt .~ [OutPlacement (sensAboveDoor senseType 10 (atFstLnkOutShiftInward 100)) outplid]
& rmOutPmnt . at i ?~ (sensAboveDoor senseType 10 (atFstLnkOutShiftInward 100))
src/Dodge/Room/Tutorial.hs
+21 -19
View File
@@ -1,5 +1,9 @@
module Dodge.Room.Tutorial (tutAnoTree) where
import Dodge.Room.Corridor
import Dodge.Room.Airlock
import Dodge.Room.RoadBlock
import Dodge.Room.Room
import Dodge.Item.Held.Cane
import Dodge.Item.Ammo
import Dodge.Annotation.Data
@@ -22,7 +26,6 @@ import Dodge.Room.Ngon
--import Dodge.Room.Link
import Dodge.Room.Procedural
import Dodge.Room.RezBox
import Dodge.Room.Room
import Dodge.Room.Warning
--import Dodge.Room.RoadBlock
import Dodge.RoomLink
@@ -40,25 +43,21 @@ import TreeHelp
tutAnoTree :: Annotation
tutAnoTree =
OnwardList $
[ AnTree $ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
[ AnTree $ return $ tToBTree "teststart" $ return $ cleatOnward corridor
, AnTree $ tutDrop
, AnTree $ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
, AnTree corDoor
, AnTree $ tutRooms
, AnTree $ pickupTut
, AnTree $ weaponTut
, AnTree $ tutDrop
-- , AnTree $ pickupTut
-- , AnTree $ weaponTut
]
weaponTut :: State LayoutVars (MetaTree Room String)
weaponTut = do
tutDrop :: State LayoutVars (MetaTree Room String)
tutDrop = do
x <- shuffleLinks $ roomNgon 6 100
& rmPmnts .:~ sps (PS 0 0) (PutFlIt $ burstRifle)
return $ tToBTree "WeaponTestTest" $ treePost $ [x]
pickupTut :: State LayoutVars (MetaTree Room String)
pickupTut = do
i <- nextLayoutInt
x <- shuffleLinks $ analyserByDoor (RequireEquipment (AMMOMAG DRUMMAG)) i $ roomNgon 6 100
& rmPmnts .:~ sps (PS 0 0) (PutFlIt $ drumMag & itConsumables ?~ 100)
return $ tToBTree "PickupTest" $ treePost $ [x, cleatOnward $ triggerDoorRoom i]
y <- decontamRoom
return $ tToBTree "TutDrop" $ treePost [x,y,roomRectAutoLinks 40 100]
tutRooms :: State LayoutVars (MetaTree Room String)
tutRooms = do
@@ -67,12 +66,15 @@ tutRooms = do
x <- shuffleLinks $ analyserByDoor (RequireEquipment (AMMOMAG DRUMMAG)) i
$ addDoorAtNthLinkToggleTerminal 1 (makeTermPara s) j
$ roomNgon 6 100
bcor <- blockedCorridor
return $ tToBTree "DoorTest" $ Node x
[Node (cleatOnward $ triggerDoorRoom i) []
,Node ( triggerDoorRoom j) []
[treeFromPost [triggerDoorRoom i] (r burstRifle)
,treeFromPost [triggerDoorRoom j] (r (drumMag & itConsumables ?~ 100))
,bcor
]
where
s = "INTERACTION TEST 1: USE KEYBOARD OR SCROLL TO ENTER COMMANDS."
s = "INTERACTION TEST: USE KEYBOARD OR SCROLL TO ENTER COMMANDS."
r x = roomRectAutoLinks 100 100 & rmPmnts .:~ sps (PS 50 0) (PutFlIt x)
tutRezBox :: RandomGen g => State g Room
tutRezBox = do
@@ -91,4 +93,4 @@ tutRezBox = do
s = tutorialMessage1
tutorialMessage1 :: String
tutorialMessage1 = "SYNTHESIS SUCCESSFUL. MOVEMENT TEST 1 INITIATED [WASD]. INTERACTION TEST 1 IN QUEUE [SPACE]."
tutorialMessage1 = "SYNTHESIS SUCCESSFUL. MOBILITY TEST INITIATED [WASD]. INTERACTION TEST IN QUEUE [SPACE]."
src/Dodge/Room/Warning.hs
+1 -1
View File
@@ -36,7 +36,7 @@ addDoorToggleTerminal = addDoorAtNthLinkToggleTerminal 0
addDoorAtNthLinkToggleTerminal :: Int -> [TerminalLine] -> Int -> Room -> Room
addDoorAtNthLinkToggleTerminal j xs i = (rmName .++~ "doorToggle-")
. (rmOutPmnt .:~ OutPlacement outplace i)
. (rmOutPmnt . at i ?~ outplace)
where
outplace =
extTrigLitPos
src/Dodge/Terminal.hs
+14 -7
View File
@@ -16,6 +16,7 @@ module Dodge.Terminal (
tlDoEffect,
) where
import Dodge.Item.Display
import Color
import Data.Char
import qualified Data.List as List
@@ -59,11 +60,12 @@ getCommand :: World
getCommand w tm = \case
TCInfo x z -> PTE.singleton x (PTE.singleton "" (makeTermPara z))
TCBase -> quitCommand <> toggleCommands tm
TCDamageCommand -> damageCodeCommand w
TCDamageCommand -> damageCodeCommand w tm
TCSensorInfo -> sensorCommand w tm
damageCodeCommand :: World -> PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
damageCodeCommand w = PTE.singleton "DAMAGECODE" $ PTE.fromList $ mapMaybe f [minBound ..]
damageCodeCommand :: World -> Terminal -> PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
damageCodeCommand w tm
= PTE.singleton "DAMAGECODE" $ PTE.fromList $ mapMaybe f [minBound ..]
where
f :: SensorType -> Maybe (String, [TerminalLine])
f st = do
@@ -82,12 +84,17 @@ decodeSensorType st w = fromMaybe [] $ do
-- ugly
sensorCommand :: World -> Terminal -> PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
sensorCommand w tm = PTE.singleton "SENSOR" $ fromMaybe mempty $ do
ProximitySensor _ d r b <- w ^? cWorld . lWorld . machines . ix (tm ^. tmMachineID) . mcType . _McSensor
ProximitySensor _ _ r b <- w ^? cWorld . lWorld . machines . ix (tm ^. tmMachineID) . mcType . _McSensor
return $ PTE.fromList
[ ("REQUIREMENT", [makeTermLine $ show r] )
, ("RADIUS", [makeTermLine $ show d])
, ("STATUS", [makeTermLine $ show b])
[ ("", makeTermPara $ sensorReqToString r b)
]
sensorReqToString :: ProximityRequirement -> Bool -> String
sensorReqToString pr = \case
True -> "SENSOR TEST PASSED."
False -> "SENSOR REQUIRES: " ++ case pr of
RequireHealth x -> "HEALTH ABOVE " ++ show x
RequireEquipment x -> itemBaseName x
toggleCommands :: Terminal -> PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])