Add more information to Room Positions
This commit is contained in:
+4
-66
@@ -24,7 +24,9 @@ module Dodge.Data
|
||||
, module MaybeHelp
|
||||
, module Dodge.Data.ItemAmount
|
||||
, module Dodge.RoomCluster.Data
|
||||
, module Dodge.Data.Room
|
||||
) where
|
||||
import Dodge.Data.Room
|
||||
import Dodge.RoomCluster.Data
|
||||
import Dodge.Data.ItemAmount
|
||||
import Dodge.ShortShow
|
||||
@@ -1426,7 +1428,8 @@ data PlacementSpot
|
||||
-- TODO attempt to unify/simplify this union type
|
||||
data Placement
|
||||
= Placement
|
||||
{ _plSpot :: PlacementSpot
|
||||
{ _plOrder :: Int
|
||||
, _plSpot :: PlacementSpot
|
||||
, _plType :: PSType
|
||||
, _plMID :: Maybe Int
|
||||
, _plIDCont :: World -> Placement -> Maybe Placement
|
||||
@@ -1473,52 +1476,6 @@ data Room = Room
|
||||
, _rmType :: RoomType
|
||||
, _rmClusterStatus :: ClusterStatus
|
||||
}
|
||||
data RoomLink = RoomLink
|
||||
{ _rlType :: S.Set RoomLinkType
|
||||
, _rlPos :: Point2
|
||||
, _rlDir :: Float
|
||||
} deriving (Eq,Ord)
|
||||
data RoomType = DefaultRoomType
|
||||
| RectRoomType
|
||||
{ _numLinkEW :: Int
|
||||
, _numLinkNS :: Int
|
||||
, _linkGapEW :: Float
|
||||
, _linkGapNS :: Float
|
||||
, _rmWidth :: Float
|
||||
, _rmHeight :: Float
|
||||
}
|
||||
deriving (Eq,Ord)
|
||||
data RoomLinkType
|
||||
= OutLink
|
||||
| InLink
|
||||
| LabLink Int
|
||||
| OnEdge CardinalPoint
|
||||
| FromEdge CardinalPoint Int
|
||||
| BlockedLink
|
||||
deriving (Eq,Ord,Show)
|
||||
data CardinalPoint
|
||||
= North
|
||||
| East
|
||||
| South
|
||||
| West
|
||||
deriving (Eq,Ord,Show)
|
||||
data RoomWire
|
||||
= --RoomWire Point2 Float
|
||||
WallWire Point2 Float Float
|
||||
|
||||
data RPLinkStatus
|
||||
= UsedOutLink
|
||||
{ _rplsType :: S.Set RoomLinkType
|
||||
, _rplsChildNum :: Int
|
||||
, _rplsOutRoomID :: Int
|
||||
}
|
||||
| UsedInLink
|
||||
{ _rplsType :: S.Set RoomLinkType
|
||||
, _rplsInRoomID :: Int
|
||||
}
|
||||
| UnusedLink { _rplsType :: S.Set RoomLinkType }
|
||||
| NotLink
|
||||
deriving (Eq,Ord,Show)
|
||||
data OutPlacement = OutPlacement
|
||||
{ _opPlacement :: Placement
|
||||
, _opPlacementID :: Int
|
||||
@@ -1527,21 +1484,6 @@ data InPlacement = InPlacement
|
||||
{ _ipPlacement :: [Placement] -> Placement
|
||||
, _ipPlacementID :: Int
|
||||
}
|
||||
data RoomPos = RoomPos
|
||||
{ _rpPos :: Point2
|
||||
, _rpDir :: Float
|
||||
, _rpType :: S.Set RoomPosType
|
||||
, _rpLinkStatus :: RPLinkStatus
|
||||
, _rpPlacementUse :: Int
|
||||
}
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data RoomPosType
|
||||
= RoomPosOnPath
|
||||
| RoomPosOffPath
|
||||
| RoomPosExLink
|
||||
| RoomPosLab Int
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
makeLenses ''CreatureState
|
||||
makeLenses ''Damage
|
||||
@@ -1621,7 +1563,3 @@ makeLenses ''RoomType
|
||||
makeLenses ''PSType
|
||||
makeLenses ''PlacementSpot
|
||||
makeLenses ''Placement
|
||||
makeLenses ''RoomLink
|
||||
makeLenses ''RoomPos
|
||||
makeLenses ''RoomPosType
|
||||
makeLenses ''RPLinkStatus
|
||||
|
||||
@@ -0,0 +1,77 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
module Dodge.Data.Room where
|
||||
import Geometry
|
||||
|
||||
import qualified Data.Set as S
|
||||
import Control.Lens
|
||||
|
||||
data RoomPos = RoomPos
|
||||
{ _rpPos :: Point2
|
||||
, _rpDir :: Float
|
||||
, _rpType :: S.Set RoomPosType
|
||||
, _rpLinkStatus :: RPLinkStatus
|
||||
, _rpPlacementUse :: Int
|
||||
}
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data RoomLink = RoomLink
|
||||
{ _rlType :: S.Set RoomLinkType
|
||||
, _rlPos :: Point2
|
||||
, _rlDir :: Float
|
||||
} deriving (Eq,Ord)
|
||||
data RoomType = DefaultRoomType
|
||||
| RectRoomType
|
||||
{ _numLinkEW :: Int
|
||||
, _numLinkNS :: Int
|
||||
, _linkGapEW :: Float
|
||||
, _linkGapNS :: Float
|
||||
, _rmWidth :: Float
|
||||
, _rmHeight :: Float
|
||||
}
|
||||
deriving (Eq,Ord)
|
||||
data RoomLinkType
|
||||
= OutLink
|
||||
| InLink
|
||||
| LabLink Int
|
||||
| OnEdge CardinalPoint
|
||||
| FromEdge CardinalPoint Int
|
||||
| BlockedLink
|
||||
deriving (Eq,Ord,Show)
|
||||
data CardinalPoint
|
||||
= North
|
||||
| East
|
||||
| South
|
||||
| West
|
||||
deriving (Eq,Ord,Show)
|
||||
data RoomWire
|
||||
= --RoomWire Point2 Float
|
||||
WallWire Point2 Float Float
|
||||
|
||||
data RPLinkStatus
|
||||
= UsedOutLink
|
||||
{ _rplsType :: S.Set RoomLinkType
|
||||
, _rplsChildNum :: Int
|
||||
, _rplsOutRoomID :: Int
|
||||
}
|
||||
| UsedInLink
|
||||
{ _rplsType :: S.Set RoomLinkType
|
||||
, _rplsInRoomID :: Int
|
||||
}
|
||||
| UnusedLink { _rplsType :: S.Set RoomLinkType }
|
||||
| NotLink
|
||||
deriving (Eq,Ord,Show)
|
||||
data PathEdge = PathFromEdge CardinalPoint Int
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data RoomPosType
|
||||
= RoomPosOnPath {_onPathEdges :: S.Set PathEdge}
|
||||
| RoomPosOffPath {_offPathEdges :: S.Set PathEdge}
|
||||
| RoomPosExLink
|
||||
| RoomPosLab Int
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
makeLenses ''RoomLink
|
||||
makeLenses ''RoomPos
|
||||
makeLenses ''RoomPosType
|
||||
makeLenses ''RPLinkStatus
|
||||
@@ -40,6 +40,7 @@ initialAnoTree :: Annotation
|
||||
initialAnoTree = OnwardList
|
||||
$ intersperse (AnTree corDoor)
|
||||
[ IntAnno $ AnTree . startRoom
|
||||
, AnRoom roomPillarsSquare
|
||||
, AnTree firstBreather
|
||||
-- , (SpecificRoom . return . tToBTree $ treePost [corridor,corridor,cleatOnward corridor])
|
||||
, AnRoom $ roomCCrits 10
|
||||
|
||||
+20
-20
@@ -20,28 +20,28 @@ import Data.Maybe
|
||||
|
||||
|
||||
spNoID :: PlacementSpot -> PSType -> Placement
|
||||
spNoID ps pst = Placement ps pst Nothing (const . const Nothing)
|
||||
spNoID ps pst = Placement 10 ps pst Nothing (const . const Nothing)
|
||||
|
||||
pContID :: PlacementSpot -> PSType -> (Int -> Maybe Placement) -> Placement
|
||||
pContID ps pt = Placement ps pt Nothing . contToIDCont
|
||||
pContID ps pt = Placement 10 ps pt Nothing . contToIDCont
|
||||
|
||||
psPtCont :: PlacementSpot -> PSType -> (Placement -> Maybe Placement) -> Placement
|
||||
psPtCont ps pt = Placement ps pt Nothing . const
|
||||
psPtCont ps pt = Placement 10 ps pt Nothing . const
|
||||
|
||||
psPt :: PlacementSpot -> PSType -> Placement
|
||||
psPt ps pt = Placement ps pt Nothing (const . const Nothing)
|
||||
psPt ps pt = Placement 10 ps pt Nothing (const . const Nothing)
|
||||
|
||||
sPS :: Point2 -> Float -> PSType -> Placement
|
||||
sPS p a pt = Placement (PS p a) pt Nothing (const . const Nothing)
|
||||
sPS p a pt = Placement 10 (PS p a) pt Nothing (const . const Nothing)
|
||||
|
||||
sps :: PlacementSpot -> PSType -> Placement
|
||||
sps ps pt = Placement ps pt Nothing (const . const Nothing)
|
||||
sps ps pt = Placement 10 ps pt Nothing (const . const Nothing)
|
||||
|
||||
plRRpt :: Int -> PSType -> Placement
|
||||
plRRpt i pt = Placement (PSRoomRand i (uncurry PS)) pt Nothing (const . const Nothing)
|
||||
plRRpt i pt = Placement 10 (PSRoomRand i (uncurry PS)) pt Nothing (const . const Nothing)
|
||||
|
||||
jsps :: Point2 -> Float -> PSType -> Maybe Placement
|
||||
jsps p a pst = Just $ Placement (PS p a) pst Nothing $ const . const Nothing
|
||||
jsps p a pst = Just $ Placement 10 (PS p a) pst Nothing $ const . const Nothing
|
||||
|
||||
jsps0 :: PSType -> Maybe Placement
|
||||
jsps0 = Just . sPS (V2 0 0) 0
|
||||
@@ -50,52 +50,52 @@ sps0 :: PSType -> Placement
|
||||
sps0 = sPS (V2 0 0) 0
|
||||
|
||||
jspsJ :: Point2 -> Float -> PSType -> Placement -> Maybe Placement
|
||||
jspsJ p a pst plm = Just $ Placement (PS p a) pst Nothing $ \_ _ -> Just plm
|
||||
jspsJ p a pst plm = Just $ Placement 10 (PS p a) pst Nothing $ \_ _ -> Just plm
|
||||
|
||||
jsps0J :: PSType -> Placement -> Maybe Placement
|
||||
jsps0J pst plm = Just $ Placement (PS (V2 0 0) 0) pst Nothing $ \_ _ -> Just plm
|
||||
jsps0J pst plm = Just $ Placement 10 (PS (V2 0 0) 0) pst Nothing $ \_ _ -> Just plm
|
||||
|
||||
ps0 :: PSType -> (Int -> Maybe Placement) -> Placement
|
||||
ps0 pst = Placement (PS (V2 0 0) 0) pst Nothing . contToIDCont
|
||||
ps0 pst = Placement 10 (PS (V2 0 0) 0) pst Nothing . contToIDCont
|
||||
|
||||
pt0 :: PSType -> (Placement -> Maybe Placement) -> Placement
|
||||
pt0 pst = Placement (PS (V2 0 0) 0) pst Nothing . const
|
||||
pt0 pst = Placement 10 (PS (V2 0 0) 0) pst Nothing . const
|
||||
|
||||
contToIDCont :: (Int -> Maybe Placement) -> World -> Placement -> Maybe Placement
|
||||
contToIDCont f _ = f . fromJust . _plMID
|
||||
|
||||
jps0' :: PSType -> (Placement -> Maybe Placement) -> Maybe Placement
|
||||
jps0' pst = Just . Placement (PS (V2 0 0) 0) pst Nothing . const
|
||||
jps0' pst = Just . Placement 10 (PS (V2 0 0) 0) pst Nothing . const
|
||||
|
||||
jps0PushPS :: PSType -> (Int -> Maybe Placement) -> Maybe Placement
|
||||
jps0PushPS pst f = Just . Placement (PSNoShiftCont (V2 0 0) 0) pst Nothing
|
||||
jps0PushPS pst f = Just . Placement 10 (PSNoShiftCont (V2 0 0) 0) pst Nothing
|
||||
$ \_ plmnt -> f (fromJust $ _plMID plmnt) <&> plSpot .~ _plSpot plmnt
|
||||
|
||||
ps0j :: PSType -> Placement -> Placement
|
||||
ps0j pst plmnt = Placement (PS (V2 0 0) 0) pst Nothing (\_ -> const $ Just plmnt)
|
||||
ps0j pst plmnt = Placement 10 (PS (V2 0 0) 0) pst Nothing (\_ -> const $ Just plmnt)
|
||||
|
||||
psj :: PlacementSpot -> PSType -> Placement -> Placement
|
||||
psj ps pst plmnt = Placement ps pst Nothing (\_ -> const $ Just plmnt)
|
||||
psj ps pst plmnt = Placement 10 ps pst Nothing (\_ -> const $ Just plmnt)
|
||||
|
||||
-- the NoShiftCont is necessary when shifting then combining rooms
|
||||
ps0jPushPS :: PSType -> Placement -> Placement
|
||||
ps0jPushPS pst plmnt = Placement (PSNoShiftCont (V2 0 0) 0) pst Nothing
|
||||
ps0jPushPS pst plmnt = Placement 10 (PSNoShiftCont (V2 0 0) 0) pst Nothing
|
||||
$ \_ p -> Just $ plmnt & plSpot .~ _plSpot p
|
||||
|
||||
-- the NoShiftCont is necessary when shifting then combining rooms
|
||||
ps0PushPS :: PSType -> (Placement -> Maybe Placement) -> Placement
|
||||
ps0PushPS pst f = Placement (PSNoShiftCont (V2 0 0) 0) pst Nothing
|
||||
ps0PushPS pst f = Placement 10 (PSNoShiftCont (V2 0 0) 0) pst Nothing
|
||||
$ \_ pl -> f pl & _Just . plSpot %~ const (_plSpot pl)
|
||||
|
||||
ps0PushPSw :: PSType -> (World -> Placement -> Maybe Placement) -> Placement
|
||||
ps0PushPSw pst f = Placement (PSNoShiftCont (V2 0 0) 0) pst Nothing
|
||||
ps0PushPSw pst f = Placement 10 (PSNoShiftCont (V2 0 0) 0) pst Nothing
|
||||
$ \w pl -> f w pl & _Just . plSpot %~ const (_plSpot pl)
|
||||
|
||||
addPlmnt :: Placement -> Placement -> Placement
|
||||
addPlmnt pl pl2 = case pl2 of
|
||||
(PlacementUsingPos p f) -> PlacementUsingPos p (fmap (addPlmnt pl) f)
|
||||
(RandomPlacement rp) -> RandomPlacement $ fmap (addPlmnt pl) rp
|
||||
(Placement ps pt mi f) -> Placement ps pt mi (fmap (fmap g) f)
|
||||
(Placement i ps pt mi f) -> Placement i ps pt mi (fmap (fmap g) f)
|
||||
PickOnePlacement {} -> error "not written how to combine PickOnePlacement with others yet"
|
||||
where
|
||||
g Nothing = Just pl
|
||||
|
||||
@@ -149,7 +149,7 @@ spanLSLightI ls h a b = ps0j (PutLS $ ls & lsParam . lsPos .~ V3 x y h)
|
||||
V2 x y = 0.5 *.* (a +.+ b)
|
||||
|
||||
spanLS :: LightSource -> Point2 -> Point2 -> Placement
|
||||
spanLS ls a b = Placement (PS (V2 x y) 0) (PutLS ls) Nothing
|
||||
spanLS ls a b = Placement 10 (PS (V2 x y) 0) (PutLS ls) Nothing
|
||||
$ const $ const $ Just $ sps0 $ PutShape $ thinHighBar h a b
|
||||
where
|
||||
V3 _ _ h = _lsPos (_lsParam ls) + 5
|
||||
|
||||
@@ -1,6 +1,8 @@
|
||||
--{-# LANGUAGE LambdaCase #-}
|
||||
module Dodge.PlacementSpot
|
||||
( atFstLnkOut
|
||||
, rpIsOnPath
|
||||
, rpIsOffPath
|
||||
, useUnusedLnk
|
||||
, psRandRanges
|
||||
, useRoomPosCond
|
||||
@@ -68,6 +70,17 @@ psposAddLabel lab = psSelect %~ (\f rp r -> f rp r & _Just . _2 . rpType %~ S.in
|
||||
rprBool :: (RoomPos -> Room -> Bool) -> PlacementSpot
|
||||
rprBool t = PSPos (useRoomPosRoomCond t) (const id) Nothing
|
||||
|
||||
rpIsOnPath :: RoomPos -> Bool
|
||||
rpIsOnPath = any f . _rpType
|
||||
where
|
||||
f RoomPosOnPath {} = True
|
||||
f _ = False
|
||||
rpIsOffPath :: RoomPos -> Bool
|
||||
rpIsOffPath = any f . _rpType
|
||||
where
|
||||
f RoomPosOffPath {} = True
|
||||
f _ = False
|
||||
|
||||
resetPLUse :: PlacementSpot -> PlacementSpot
|
||||
resetPLUse (PSPos f g fallback) = PSPos f' g fallback
|
||||
where
|
||||
@@ -109,7 +122,7 @@ 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)
|
||||
&& RoomPosOffPath `S.member` _rpType rp
|
||||
&& rpIsOffPath rp
|
||||
|
||||
unusedSpotAwayFromInLink :: Float -> PlacementSpot
|
||||
unusedSpotAwayFromInLink x = rprBool $ \rp r -> _rpLinkStatus rp == NotLink
|
||||
@@ -123,8 +136,8 @@ twoRoomPoss :: (RoomPos -> Room -> Bool)
|
||||
-> (RoomPos -> Room -> Bool)
|
||||
-> (PlacementSpot -> PlacementSpot -> Placement)
|
||||
-> Placement
|
||||
twoRoomPoss cond1 cond2 f = Placement (rprBool cond1) PutNothing Nothing
|
||||
$ \_ pl1 -> Just $ Placement (rprBool cond2) PutNothing Nothing
|
||||
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
|
||||
|
||||
@@ -21,9 +21,11 @@ roomsContaining crs its = tToBTree "roomsContaining" <$> roomsContaining' crs it
|
||||
roomsContaining' :: RandomGen g => [Creature] -> [Item] -> State g (Tree Room)
|
||||
roomsContaining' crs its = do
|
||||
endroom <- join $ takeOne
|
||||
[ randomFourCornerRoomCrsIts crs its
|
||||
, tanksRoom crs its
|
||||
, roomPillarsContaining crs its
|
||||
[roomPillarsSquare
|
||||
-- [ randomFourCornerRoomCrsIts crs its
|
||||
-- , tanksRoom crs its
|
||||
-- , roomPillarsContaining crs its
|
||||
-- , roomPillarsPassage <&> rmPmnts .++~ crsItmsUnused crs its
|
||||
]
|
||||
return (pure $ cleatOnward endroom)
|
||||
|
||||
@@ -31,10 +33,11 @@ roomPillarsContaining :: RandomGen g => [Creature] -> [Item] -> State g Room
|
||||
roomPillarsContaining crs itms = do
|
||||
(w,wn) <- takeOne [(240,2),(340,3)]
|
||||
(h,hn) <- takeOne [(240,2),(340,3)]
|
||||
let plmnts =
|
||||
map (\it -> sps0 (PutFlIt it) & plSpot .~ anyUnusedSpot) itms
|
||||
++ map (\cr -> sps0 (PutCrit cr) & plSpot .~ unusedSpotAwayFromLink 50) crs
|
||||
roomPillars 30 w h wn hn <&> rmPmnts .++~ plmnts
|
||||
roomPillars 30 w h wn hn <&> rmPmnts .++~ crsItmsUnused crs itms
|
||||
|
||||
crsItmsUnused :: [Creature] -> [Item] -> [Placement]
|
||||
crsItmsUnused crs itms = map (\it -> sps0 (PutFlIt it) & plSpot .~ anyUnusedSpot) itms
|
||||
++ map (\cr -> sps0 (PutCrit cr) & plSpot .~ unusedSpotAwayFromLink 50) crs
|
||||
|
||||
|
||||
pedestalRoom :: RandomGen g => Item -> State g Room
|
||||
|
||||
+16
-3
@@ -4,6 +4,7 @@ module Dodge.Room.Path
|
||||
, linksAndPath'
|
||||
, makeGrid
|
||||
, createPathGrid
|
||||
, gridPoints''
|
||||
)
|
||||
where
|
||||
--import Dodge.LevelGen.Data
|
||||
@@ -85,10 +86,22 @@ makeGrid x nx y ny
|
||||
. concatMap (\p -> map (Tup.both (p +.+)) $ makeRect x y)
|
||||
$ gridPoints x nx y ny
|
||||
|
||||
--gridPoints :: Float -> Int -> Float -> Int -> [Point2]
|
||||
--gridPoints x nx y ny = [V2 a b | a <- take nx $ scanl (+) 0 $ repeat x
|
||||
-- , b <- take ny $ scanl (+) 0 $ repeat y
|
||||
-- ]
|
||||
gridPoints :: Float -> Int -> Float -> Int -> [Point2]
|
||||
gridPoints x nx y ny = [V2 a b | a <- take nx $ scanl (+) 0 $ repeat x
|
||||
, b <- take ny $ scanl (+) 0 $ repeat y
|
||||
]
|
||||
gridPoints x nx y ny = map f $ gridPoints' nx ny
|
||||
where
|
||||
f (a,b) = V2 (fromIntegral a * x) (fromIntegral b * y)
|
||||
|
||||
gridPoints'' :: Float -> Int -> Float -> Int -> [(Point2,(Int,Int))]
|
||||
gridPoints'' x nx y ny = map f $ gridPoints' nx ny
|
||||
where
|
||||
f (a,b) = (V2 (fromIntegral a * x) (fromIntegral b * y), (a,b))
|
||||
|
||||
gridPoints' :: Int -> Int -> [(Int,Int)]
|
||||
gridPoints' nx ny = [(x,y) | x <- [0..nx-1], y <- [0..ny-1]]
|
||||
|
||||
makeRect :: Float -> Float -> [(Point2,Point2)]
|
||||
makeRect x y = map (bimap toV2 toV2) [((0,0),(x,0))
|
||||
|
||||
@@ -7,6 +7,7 @@ import Dodge.LevelGen.Data
|
||||
import Dodge.Placement.Instance
|
||||
--import Dodge.LevelGen.Data
|
||||
import Dodge.Room.Procedural
|
||||
import Dodge.Room.Link
|
||||
import Geometry
|
||||
import LensHelp
|
||||
|
||||
@@ -28,6 +29,9 @@ blockPillar w' h' = ps0jPushPS (aline tl tr)
|
||||
bl = V2 (-w) (-h)
|
||||
aline = PutLineBlock baseBlockPane StoneBlock 9 9
|
||||
|
||||
smallPillar :: PSType
|
||||
smallPillar = PutBlock StoneBlock 5 [5,5] baseBlockPane $ reverse $ square 5
|
||||
|
||||
crossPillar :: Float -> Float -> Placement
|
||||
crossPillar w' h' = ps0jPushPS (aline (V2 (-w) 0) (V2 w 0))
|
||||
$ sps0 (aline (V2 0 (-h)) (V2 0 h))
|
||||
@@ -36,14 +40,35 @@ crossPillar w' h' = ps0jPushPS (aline (V2 (-w) 0) (V2 w 0))
|
||||
h = h' - 9
|
||||
aline = PutLineBlock baseBlockPane StoneBlock 9 9
|
||||
|
||||
--longPillars :: Float -> Float
|
||||
roomPillarsSquare :: RandomGen g => State g Room
|
||||
roomPillarsSquare = return $ roomRectAutoLinks 400 400
|
||||
& rmPmnts .++~ [sps (rprBool $ \rp _ -> t rp) smallPillar
|
||||
,sps (rprBool $ \rp _ -> t rp) smallPillar
|
||||
,sps (rprBool $ \rp _ -> t rp) smallPillar
|
||||
,sps (rprBool $ \rp _ -> t rp) smallPillar
|
||||
,sps (rprBool $ \rp _ -> t rp) smallPillar
|
||||
]
|
||||
where
|
||||
t rp = any f (_rpType rp) && _rpPlacementUse rp == 0
|
||||
f rpt = maybe False (PathFromEdge West 1 `S.member`) (rpt ^? onPathEdges)
|
||||
|
||||
roomPillarsPassage :: RandomGen g => State g Room
|
||||
roomPillarsPassage = do
|
||||
let rm = roomRect 100 300 1 3
|
||||
shuffleLinks $ rm & rmPmnts .~
|
||||
[mntLS iShape (V2 50 0) (V3 50 10 90)
|
||||
,mntLS iShape (V2 50 300) (V3 50 290 90)
|
||||
,mntLS iShape (V2 0 150) (V3 10 150 90)
|
||||
,mntLS iShape (V2 100 150) (V3 90 150 90)
|
||||
] ++
|
||||
[ sPS (V2 30 y) 0 smallPillar | y <- [50,90.. 250] ] ++
|
||||
[ sPS (V2 70 y) 0 smallPillar | y <- [50,90.. 250] ]
|
||||
roomPillars :: RandomGen g => Float -> Float -> Float -> Int -> Int -> State g Room
|
||||
roomPillars pillarsize w h wn hn = do
|
||||
let rm = roomRect w h wn hn
|
||||
npillars = length $ filter (S.member RoomPosOffPath . _rpType) $ _rmPos rm
|
||||
npillars = length $ filter rpIsOffPath $ _rmPos rm
|
||||
let plmnts = replicate npillars (blockPillar (0.5*pilw) (0.5*pilh) & plSpot .~ rprBool
|
||||
(\rp _ -> RoomPosOffPath `S.member` _rpType rp
|
||||
(\rp _ -> rpIsOffPath rp
|
||||
&& _rpPlacementUse rp == 0
|
||||
&& _rpLinkStatus rp == NotLink )
|
||||
)
|
||||
|
||||
@@ -49,8 +49,9 @@ roomRect x y xn yn = defaultRoom
|
||||
, _rmLinks = lnks
|
||||
, _rmName = "rect"
|
||||
, _rmPath = concatMap doublePair pth
|
||||
, _rmPos = map (roomposat RoomPosOnPath) posps
|
||||
++ map (roomposat RoomPosOffPath) interposps
|
||||
--, _rmPos = map (roomposat (RoomPosOnPath S.empty)) posps
|
||||
, _rmPos = map (makeonpos) posps'
|
||||
++ map (roomposat (RoomPosOffPath S.empty)) interposps
|
||||
, _rmPmnts = []
|
||||
, _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)]
|
||||
, _rmFloor = Tiled [Tile
|
||||
@@ -85,6 +86,14 @@ roomRect x y xn yn = defaultRoom
|
||||
m edge edgefrom1 edgefrom2 = zipWith (lnkBothAnd (OnEdge edge) edgefrom1 edgefrom2) [0..]
|
||||
. zipCountDown
|
||||
pth = linksAndPath' lnks $ map (bimap (+.+ V2 20 20) (+.+ V2 20 20)) (makeGrid xd xn yd yn)
|
||||
makeonpos (p,a) = RoomPos p 0 (S.singleton $ RoomPosOnPath $ makerpedges a) NotLink 0
|
||||
makerpedges (a,b) = S.fromList
|
||||
[PathFromEdge South b
|
||||
,PathFromEdge North (yn-b)
|
||||
,PathFromEdge East (yn-a)
|
||||
,PathFromEdge West a
|
||||
]
|
||||
posps' = map (over _1 (+.+ V2 20 20)) $ gridPoints'' xd (xn+1) yd (xn+1)
|
||||
posps = map (+.+ V2 20 20) $ gridPoints xd (xn+1) yd (yn+1)
|
||||
interposps = map (+.+ V2 (20 + xd/2) (20 + yd/2)) $ gridPoints xd xn yd yn
|
||||
|
||||
|
||||
@@ -40,9 +40,9 @@ roomC :: RandomGen g => Float -> Float -> State g Room
|
||||
roomC w h = do
|
||||
wallf <- takeOne [ crystalLine , windowLine ]
|
||||
ntanks <- takeOne [0,0,0,0,0,1,1,1,1,2,3,4]
|
||||
thetank <- randomTank <&> plSpot .~ (rprBool $ \rp _ ->
|
||||
thetank <- randomTank <&> plSpot .~ rprBool (\rp _ ->
|
||||
_rpPlacementUse rp == 0
|
||||
&& RoomPosOffPath `S.member` _rpType rp
|
||||
&& rpIsOffPath rp
|
||||
&& (xV2 (_rpPos rp) > w / 2 + 5 || xV2 (_rpPos rp) < w / 2 - 5 ))
|
||||
maybeaddgird <- takeOne [return, addRandomGirderFrom West 0, addRandomGirderFrom North 0]
|
||||
maybeaddgird =<< shuffleLinks (roomRectAutoLinks w h
|
||||
@@ -196,14 +196,14 @@ weaponBetweenPillars = do
|
||||
(w,wn) <- takeOne [(240,2),(340,3)]
|
||||
(h,hn) <- takeOne [(240,2),(340,3)]
|
||||
let wpPos = rprBool $ \rp r -> and
|
||||
[ RoomPosOnPath `S.member` _rpType rp
|
||||
[ rpIsOnPath rp
|
||||
, _rpPlacementUse rp == 0
|
||||
, _rpLinkStatus rp == NotLink
|
||||
, any ((<100) . dist (_rpPos rp)) (usedRoomInLinkPoss r)
|
||||
]
|
||||
ncrits <- state $ randomR (1,3)
|
||||
critPlacementSpots <- replicateM ncrits $ randDirPS $ rprBool $ \rp r ->
|
||||
RoomPosOnPath `S.member` _rpType rp
|
||||
rpIsOnPath rp
|
||||
&& _rpPlacementUse rp == 0
|
||||
&& all ((>100) . dist (_rpPos rp)) (usedRoomLinkPoss r)
|
||||
fmap pure $ roomPillars 30 w h wn hn
|
||||
@@ -242,7 +242,7 @@ deadEndRoom = defaultRoom
|
||||
weaponRoom :: RandomGen g => Int -> State g (MetaTree Room String)
|
||||
weaponRoom i = join $ takeOne
|
||||
[ weaponEmptyRoom >>= rToOnward "weaponEmptyRoom"
|
||||
, weaponUnderCrits i
|
||||
, weaponUnderCrits i -- this int is used for PickOnePlacement
|
||||
, weaponBehindPillar >>= rToOnward "weaponBehindPillar"
|
||||
, weaponBetweenPillars >>= rToOnward "weaponBetweenPillars"
|
||||
, weaponLongCorridor >>= rToOnward "weaponLongCorridor"
|
||||
@@ -300,7 +300,7 @@ pistolerRoom :: RandomGen g => State g Room
|
||||
pistolerRoom = do
|
||||
(w,wn) <- takeOne [(200,3),(255,4)]
|
||||
roomPillars 10 w 200 wn 3 <&> rmPmnts .++~ replicate 3
|
||||
(spNoID (rprBool $ \rp _ -> _rpPlacementUse rp == 0 && RoomPosOnPath `S.member` _rpType rp)
|
||||
(spNoID (rprBool $ \rp _ -> _rpPlacementUse rp == 0 && rpIsOnPath rp)
|
||||
(PutCrit pistolCrit))
|
||||
|
||||
shootingRange :: RandomGen g => State g (MetaTree Room String)
|
||||
@@ -328,7 +328,7 @@ spawnerRoom = do
|
||||
x <- state $ randomR (250,300)
|
||||
y <- state $ randomR (300,400)
|
||||
roomWithSpawner <- roomC x y <&> rmPmnts .:~ spNoID
|
||||
(rprBool $ \rp _ -> _rpPlacementUse rp == 0 && RoomPosOnPath `S.member` _rpType rp
|
||||
(rprBool $ \rp _ -> _rpPlacementUse rp == 0 && rpIsOnPath rp
|
||||
&& xV2 (_rpPos rp) < x/2 && yV2 (_rpPos rp) < y/2 )
|
||||
(PutCrit spawnerCrit)
|
||||
aRoom <- airlock
|
||||
|
||||
@@ -55,6 +55,7 @@ powerFakeout = do
|
||||
, keyholeCorridor, corridor
|
||||
,cleatOnward door]
|
||||
|
||||
-- the i is used either for a PickOnePlacement or a room id, this is not great
|
||||
startRoom :: RandomGen g => Int -> State g (MetaTree Room String)
|
||||
startRoom i = join $ takeOne
|
||||
[ attachOnward "startThenWeaponRoom" <$> preCritStart <*> weaponRoom i
|
||||
|
||||
Reference in New Issue
Block a user