Add rooms, placements and room positions
This commit is contained in:
+6
-6
@@ -215,16 +215,16 @@ gameRoomFromRoom rm = GameRoom
|
||||
[p +.+ 10 *.* unitVectorAtAngle a
|
||||
,p -.- 10 *.* unitVectorAtAngle a
|
||||
]
|
||||
filterUnusedLinks (UnusedLink p _) = Just p
|
||||
filterUnusedLinks (UnusedLink p _ _) = Just p
|
||||
filterUnusedLinks _ = Nothing
|
||||
filterUsedLinks (UsedOutLink _ _ p a) = doubleShift p a
|
||||
filterUsedLinks (UsedInLink _ p a) = doubleShift p a
|
||||
filterUsedLinks (UsedOutLink _ _ p a _) = doubleShift p a
|
||||
filterUsedLinks (UsedInLink _ p a _) = doubleShift p a
|
||||
filterUsedLinks _ = []
|
||||
undir (UsedOutLink _ _ _ a) = Just $ 0.5*pi + a + snd (_rmShift rm)
|
||||
undir (UsedInLink _ _ a) = Just $ 0.5*pi + a + snd (_rmShift rm)
|
||||
undir (UsedOutLink _ _ _ a _) = Just $ 0.5*pi + a + snd (_rmShift rm)
|
||||
undir (UsedInLink _ _ a _) = Just $ 0.5*pi + a + snd (_rmShift rm)
|
||||
undir _ = Nothing
|
||||
closePoints x y = roundPoint2 x == roundPoint2 y
|
||||
getDir (UsedInLink _ _ a:_) = a + snd (_rmShift rm)
|
||||
getDir (UsedInLink _ _ a _:_) = a + snd (_rmShift rm)
|
||||
getDir (_:xs) = getDir xs
|
||||
getDir _ = 0 -- fallback
|
||||
|
||||
|
||||
@@ -104,13 +104,15 @@ data RoomLinkType
|
||||
| InLink
|
||||
| LabLink Int
|
||||
| OnEdge CardinalPoint
|
||||
deriving (Eq,Ord)
|
||||
| FromSouth Int
|
||||
| FromWest Int
|
||||
deriving (Eq,Ord,Show)
|
||||
data CardinalPoint
|
||||
= North
|
||||
| East
|
||||
| South
|
||||
| West
|
||||
deriving (Eq,Ord)
|
||||
deriving (Eq,Ord,Show)
|
||||
data RoomWire
|
||||
= --RoomWire Point2 Float
|
||||
WallWire Point2 Float Float
|
||||
@@ -120,32 +122,49 @@ data RoomPos
|
||||
,_rpOutRoomID :: Int
|
||||
,_rpPos :: Point2
|
||||
,_rpDir :: Float
|
||||
,_rpLinkType :: S.Set RoomLinkType
|
||||
}
|
||||
| UsedInLink
|
||||
{_rpInRoomID :: Int
|
||||
,_rpPos :: Point2
|
||||
,_rpDir ::Float
|
||||
,_rpDir :: Float
|
||||
,_rpLinkType :: S.Set RoomLinkType
|
||||
}
|
||||
| UnusedLink
|
||||
{_rpPos :: Point2
|
||||
,_rpDir ::Float
|
||||
,_rpLinkType :: S.Set RoomLinkType
|
||||
}
|
||||
| UsedLink
|
||||
{_rpPos :: Point2
|
||||
,_rpDir :: Float
|
||||
,_rpLinkType :: S.Set RoomLinkType
|
||||
}
|
||||
| UsedSpot
|
||||
{_rpPos :: Point2
|
||||
,_rpDir :: Float
|
||||
,_rpType :: S.Set RoomPosType
|
||||
}
|
||||
| UnusedSpot
|
||||
{_rpPos :: Point2
|
||||
,_rpDir :: Float
|
||||
,_rpType :: S.Set RoomPosType
|
||||
}
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data RoomPosType
|
||||
= RoomPosOnPath
|
||||
| RoomPosOffPath
|
||||
| RoomPosExLink
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
makeLenses ''Room
|
||||
makeLenses ''PSType
|
||||
makeLenses ''PlacementSpot
|
||||
makeLenses ''Placement
|
||||
makeLenses ''RoomLink
|
||||
makeLenses ''RoomPos
|
||||
makeLenses ''RoomPosType
|
||||
|
||||
spNoID :: PlacementSpot -> PSType -> Placement
|
||||
spNoID ps pst = Placement ps pst Nothing (const Nothing)
|
||||
@@ -196,7 +215,7 @@ jps0 :: PSType -> (Int -> Maybe Placement) -> Maybe Placement
|
||||
jps0 pst = Just . Placement (PS (V2 0 0) 0) pst Nothing . contToIDCont
|
||||
|
||||
jps0PushPS :: PSType -> (Int -> Maybe Placement) -> Maybe Placement
|
||||
jps0PushPS pst f = Just . Placement (PS (V2 0 0) 0) pst Nothing
|
||||
jps0PushPS pst f = Just . Placement (PSNoShiftCont (V2 0 0) 0) pst Nothing
|
||||
$ \plmnt -> f (fromJust $ _plMID plmnt) <&> plSpot .~ _plSpot plmnt
|
||||
|
||||
ps0j :: PSType -> Placement -> Placement
|
||||
|
||||
+29
-9
@@ -24,32 +24,52 @@ itemRooms :: RandomGen g => [(CombineType, State g (SubCompTree Room))]
|
||||
itemRooms =
|
||||
[ (LAUNCHER , join $ takeOne
|
||||
[corridorBoss launcherCrit
|
||||
,roomsContaining $ map makeTypeCraft [TUBE,TUBE,HARDWARE]
|
||||
, rc $ map makeTypeCraft [TUBE,TUBE,HARDWARE]
|
||||
]
|
||||
)
|
||||
, (MINIGUN , join $ takeOne [roomMiniIntro, minigunFakeout] )
|
||||
, (LASGUN , join $ takeOne
|
||||
[roomsContaining $ map makeTypeCraft [PRISM,PIPE,PIPE,HARDWARE]
|
||||
[rc $ map makeTypeCraft [PRISM,PIPE,PIPE,HARDWARE]
|
||||
]
|
||||
)
|
||||
, (SPARKGUN , join $ takeOne
|
||||
[roomsContaining $ map makeTypeCraft [TRANSFORMER,CAN,CAN]
|
||||
[rc $ map makeTypeCraft [TRANSFORMER,CAN,CAN]
|
||||
]
|
||||
)
|
||||
, (FLATSHIELD , join $ takeOne
|
||||
[roomsContaining $ map makeTypeCraft [PLATE,PLATE]
|
||||
,roomsContaining $ map makeTypeCraft [DRUM,DRUM,PLATE]
|
||||
[rc $ map makeTypeCraft [PLATE,PLATE]
|
||||
,rc $ map makeTypeCraft [DRUM,DRUM,PLATE]
|
||||
]
|
||||
)
|
||||
, (SNIPERRIFLE , join $ takeOne
|
||||
[roomsContaining [sniperRifle]
|
||||
[rc [sniperRifle]
|
||||
]
|
||||
)
|
||||
]
|
||||
where
|
||||
rc its = do
|
||||
sc <- someCrits
|
||||
roomsContaining sc its
|
||||
|
||||
roomsContaining :: RandomGen g => [Item] -> State g (SubCompTree Room)
|
||||
roomsContaining its = do
|
||||
endroom <- randomFourCornerRoom its
|
||||
someCrits :: RandomGen g => State g [Creature]
|
||||
someCrits = do
|
||||
nCrits <- state $ randomR (1,3)
|
||||
fmap (take nCrits) . shuffle $ [spreadGunCrit,pistolCrit,autoCrit,armourChaseCrit]
|
||||
++ replicate 20 chaseCrit
|
||||
|
||||
|
||||
--addcrits :: RandomGen g => [Item] -> State g (SubCompTree Room)
|
||||
--addcrits its = do
|
||||
-- nCrits <- state $ randomR (1,3)
|
||||
-- crits <- takeN nCrits <=< shuffle $ fmap PutCrit $ [spreadGunCrit,pistolCrit,autoCrit,armourChaseCrit]
|
||||
-- return $ roomsContaining crits its
|
||||
|
||||
roomsContaining :: RandomGen g => [Creature] -> [Item] -> State g (SubCompTree Room)
|
||||
roomsContaining crs its = do
|
||||
endroom <- join $ takeOne
|
||||
[ randomFourCornerRoomCrsIts crs its
|
||||
, tanksRoom crs its
|
||||
]
|
||||
return $ treeFromPost [] $ PassDown endroom
|
||||
|
||||
corridorBoss :: RandomGen g => Creature -> State g (SubCompTree Room)
|
||||
|
||||
@@ -107,13 +107,6 @@ mntLightLnkCond f = RandomPlacement $ do
|
||||
shp <- takeOne [vShape,iShape,lShape,jShape,liShape]
|
||||
return $ mntLSCond shp f
|
||||
|
||||
unusedLnkToPS :: RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)
|
||||
unusedLnkToPS rp _ = case rp of
|
||||
UnusedLink p a -> Just (PS p a,UsedSpot p a)
|
||||
-- UsedInLink _ p a -> Just (PS p a,UsedSpot p a)
|
||||
-- UsedOutLink _ _ p a -> Just (PS p a,UsedSpot p a)
|
||||
_ -> Nothing
|
||||
|
||||
spanLSLightI :: LightSource -> Float -> Point2 -> Point2 -> Placement
|
||||
spanLSLightI ls h a b = ps0j (PutLS $ ls & lsParam . lsPos .~ V3 x y h)
|
||||
$ sps0 $ PutShape $ thinHighBar h a b
|
||||
|
||||
@@ -1,7 +1,6 @@
|
||||
module Dodge.Placement.Instance.Tank where
|
||||
import Dodge.Data
|
||||
--import Dodge.Placement.PlaceSpot
|
||||
import Dodge.Placement.Shift
|
||||
import Dodge.LevelGen.Data
|
||||
import Dodge.Room.Foreground
|
||||
import Dodge.Default.Wall
|
||||
@@ -10,90 +9,74 @@ import Shape
|
||||
import Color
|
||||
--import Quaternion
|
||||
|
||||
roundTank :: Color -> Float -> Float -> Placement
|
||||
roundTank col x y = shiftPlacement (V2 x y,0) $ ps0j
|
||||
(PutShape $ colorSH col $
|
||||
upperPrismPoly 31 thecircle
|
||||
<> foldMap toprail ( take 8 [0,pi/4..])
|
||||
)
|
||||
$ sps0 $ PutWall thecircle defaultWall {_wlDraw = False, _wlColor = col, _wlRotateTo = False}
|
||||
tankShape :: [Point2] -> (Color -> Color -> Shape) -> Color -> Color -> Placement
|
||||
tankShape baseshape facade col col' = ps0jPushPS
|
||||
(PutShape $ colorSH col (upperPrismPoly 31 baseshape) <> facade col col')
|
||||
$ sps0 $ PutWall baseshape defaultWall
|
||||
{_wlDraw = False, _wlColor = col, _wlRotateTo = False, _wlOpacity = SeeAbove}
|
||||
|
||||
roundTank :: Color -> Color -> Placement
|
||||
roundTank = tankShape (polyCirc 4 20)
|
||||
$ \_ c' -> colorSH c' $ foldMap toprail (take 8 [0,pi/4..])
|
||||
where
|
||||
toprail a = rotateSH a $ thinHighBar 31 (V2 0 20) (rotateV (pi/4) $ V2 0 20)
|
||||
thecircle = polyCirc 4 20
|
||||
|
||||
roundTankCross :: Color -> Float -> Float -> Placement
|
||||
roundTankCross col x y = shiftPlacement (V2 x y,0) $ ps0j
|
||||
(PutShape $ colorSH col $
|
||||
upperPrismPoly 31 thecircle
|
||||
<> thinHighBar 31 (V2 20 0) (V2 (-20) 0)
|
||||
roundTankCross :: Color -> Color -> Placement
|
||||
roundTankCross = tankShape (polyCirc 4 20)
|
||||
$ \_ c -> colorSH c $ thinHighBar 31 (V2 20 0) (V2 (-20) 0)
|
||||
<> thinHighBar 31 (V2 0 20) (V2 0 (-20))
|
||||
)
|
||||
$ sps0 $ PutWall thecircle defaultWall {_wlDraw = False, _wlColor = col, _wlRotateTo = False}
|
||||
where
|
||||
thecircle = polyCirc 4 20
|
||||
|
||||
tankRectCross :: Float -> Float -> Color -> Float -> Float -> Placement
|
||||
tankRectCross w h col x y = shiftPlacement (V2 x y,0) $ ps0j
|
||||
(PutShape $ colorSH col $
|
||||
upperPrismPoly 31 therect
|
||||
<> thinHighBar 31 (V2 w 0) (V2 (-w) 0)
|
||||
<> thinHighBar 31 (V2 0 h) (V2 0 (-h))
|
||||
)
|
||||
$ sps0 $ PutWall therect defaultWall {_wlDraw = False, _wlColor = col, _wlRotateTo = False}
|
||||
where
|
||||
therect = rectWH w h
|
||||
tankRectCross :: Float -> Float -> Color -> Color -> Placement
|
||||
tankRectCross = tankRectDecorate $ \ w h _ c -> colorSH c $
|
||||
thinHighBar 31 (V2 w 0) (V2 (-w) 0)
|
||||
<> thinHighBar 31 (V2 0 h) (V2 0 (-h))
|
||||
|
||||
tankSquareCross :: Color -> Float -> Float -> Placement
|
||||
tankSquareCross :: Color -> Color -> Placement
|
||||
tankSquareCross = tankRectCross 20 20
|
||||
|
||||
tankRectDecorate :: (Float -> Float -> Color -> Color -> Shape)
|
||||
-> Float -> Float -> Color -> Color -> Placement
|
||||
tankRectDecorate f w h = tankShape (rectWH w h) (f w h)
|
||||
|
||||
tankRect :: Float -> Float -> Color -> Float -> Float -> Placement
|
||||
tankRect w h col x y = shiftPlacement (V2 x y,0) $ ps0j
|
||||
(PutShape $ colorSH col
|
||||
$ upperPrismPoly 31 therect
|
||||
<> foldMap f [(w',-w',h',h'),(w',-w',-h',-h'),(w',w',h',-h'),(-w',-w',h',-h')]
|
||||
)
|
||||
$ sps0 $ PutWall therect defaultWall
|
||||
{_wlDraw = False, _wlColor = col, _wlRotateTo = False, _wlOpacity = SeeAbove}
|
||||
tankRect :: Float -> Float -> Color -> Color -> Placement
|
||||
tankRect = tankRectDecorate g
|
||||
where
|
||||
therect = rectWH w h
|
||||
w' = w - 1.5
|
||||
h' = h - 1.5
|
||||
f (a,b,c,d) = thinHighBar 31 (V2 a b) (V2 c d)
|
||||
g w h _ col = colorSH col $ foldMap f
|
||||
[(w',-w',h',h')
|
||||
,(w',-w',-h',-h')
|
||||
,(w',w',h',-h')
|
||||
,(-w',-w',h',-h')
|
||||
]
|
||||
where
|
||||
w' = w - 1.5
|
||||
h' = h - 1.5
|
||||
f (a,c,b,d) = thinHighBar 31 (V2 a b) (V2 c d)
|
||||
|
||||
tankSquare :: Color -> Float -> Float -> Placement
|
||||
tankSquare :: Color -> Color -> Placement
|
||||
tankSquare = tankRect 20 20
|
||||
|
||||
tankRectEmboss :: Float -> Float -> Color -> Float -> Float -> Placement
|
||||
tankRectEmboss w h col x y = shiftPlacement (V2 x y,0) $ ps0j
|
||||
(PutShape $ colorSH col $
|
||||
upperPrismPoly 31 therect
|
||||
<> embossingR
|
||||
<> rotateSH pi embossingR
|
||||
<> thinHighBar 38 (V2 (-0.3*w) 0) (V2 (0.3*w) 0)
|
||||
)
|
||||
$ sps0 $ PutWall therect defaultWall {_wlDraw = False, _wlColor = col, _wlRotateTo = False}
|
||||
tankRectEmboss :: Float -> Float -> Color -> Color -> Placement
|
||||
tankRectEmboss = tankRectDecorate f
|
||||
where
|
||||
w' = 0.3 * w
|
||||
therect = rectWH w h
|
||||
embossingR = prismPoly
|
||||
[V3 w h 31,V3 w (0.3*h) 41,V3 w (-0.3*h) 41,V3 w (-h) 31]
|
||||
[V3 w' h 31,V3 w' (0.3*h) 41,V3 w' (-0.3*h) 41,V3 w' (-h) 31]
|
||||
f w h _ c = embossingR
|
||||
<> rotateSH pi embossingR
|
||||
<> colorSH c (thinHighBar 38 (V2 (-0.3*w) 0) (V2 (0.3*w) 0))
|
||||
where
|
||||
w' = 0.3 * w
|
||||
embossingR = colorSH c $ prismPoly
|
||||
[V3 w h 31,V3 w (0.3*h) 41,V3 w (-0.3*h) 41,V3 w (-h) 31]
|
||||
[V3 w' h 31,V3 w' (0.3*h) 41,V3 w' (-0.3*h) 41,V3 w' (-h) 31]
|
||||
|
||||
tankSquareEmboss :: Color -> Float -> Float -> Placement
|
||||
tankSquareEmboss :: Color -> Color -> Placement
|
||||
tankSquareEmboss = tankRectEmboss 20 20
|
||||
|
||||
tankRectEmboss4 :: Float -> Float -> Color -> Float -> Float -> Placement
|
||||
tankRectEmboss4 w h col x y = shiftPlacement (V2 x y,0) $ ps0j
|
||||
(PutShape $ colorSH col $
|
||||
upperPrismPoly 31 therect
|
||||
<> foldMap f [(w,h),(-w,h),(w,-h),(-w,-h)]
|
||||
)
|
||||
$ sps0 $ PutWall therect defaultWall {_wlDraw = False, _wlColor = col, _wlRotateTo = False}
|
||||
tankRectEmboss4 :: Float -> Float -> Color -> Color -> Placement
|
||||
tankRectEmboss4 = tankRectDecorate g
|
||||
where
|
||||
therect = rectWH w h
|
||||
f (a,b) = translateSH (V3 (a/2) (b/2) 31) embossing
|
||||
embossing = upperPrismPolyHalf 10 $ rectNSEW (h/2) (-h/2) (w/2) (-w/2)
|
||||
g w h _ c = colorSH c $ foldMap f [(w,h),(-w,h),(w,-h),(-w,-h)]
|
||||
where
|
||||
f (a,b) = translateSH (V3 (a/2) (b/2) 31) embossing
|
||||
embossing = upperPrismPolyHalf 10 $ rectNSEW (h/2) (-h/2) (w/2) (-w/2)
|
||||
|
||||
tankSquareEmboss4 :: Color -> Float -> Float -> Placement
|
||||
tankSquareEmboss4 :: Color -> Color -> Placement
|
||||
tankSquareEmboss4 = tankRectEmboss4 20 20
|
||||
|
||||
+83
-13
@@ -2,16 +2,18 @@ module Dodge.PlacementSpot where
|
||||
import Dodge.LevelGen.Data
|
||||
import Geometry
|
||||
|
||||
import Control.Lens
|
||||
import Data.Maybe
|
||||
import Data.Bifunctor
|
||||
import Control.Monad.State
|
||||
import System.Random
|
||||
import qualified Data.Set as S
|
||||
|
||||
setDirPS :: Float -> PlacementSpot -> PlacementSpot
|
||||
setDirPS a ps = case ps of
|
||||
PS p _ -> PS p a
|
||||
PSNoShiftCont p _ -> PS p a
|
||||
PSPos f re fb -> PSPos (\rp r -> fmap (first (setDirPS a)) (f rp r)) re fb
|
||||
PSPos f rmeff fb -> PSPos (\rp r -> fmap (first (setDirPS a)) (f rp r)) rmeff fb
|
||||
PSRoomRand i f -> PSRoomRand i (fmap (setDirPS a) f)
|
||||
|
||||
randDirPS :: RandomGen g => PlacementSpot -> State g PlacementSpot
|
||||
@@ -19,23 +21,83 @@ randDirPS ps = do
|
||||
a <- state $ randomR (0,pi*2)
|
||||
return $ setDirPS a ps
|
||||
|
||||
anyUnusedSpot :: PlacementSpot
|
||||
anyUnusedSpot = PSPos f (const id) Nothing
|
||||
where
|
||||
f rp _ = case rp of
|
||||
UnusedSpot p a t -> Just (PS p a,UsedSpot p a t)
|
||||
_ -> Nothing
|
||||
|
||||
unusedSpotAwayFromLink :: Float -> PlacementSpot
|
||||
unusedSpotAwayFromLink x = PSPos f (const id) Nothing
|
||||
where
|
||||
f rp r = case rp of
|
||||
UnusedSpot p a t
|
||||
| all ( (>x) . dist p ) (usedRoomLinkPoss r)
|
||||
-> Just (PS p a,UsedSpot p a t)
|
||||
_ -> Nothing
|
||||
|
||||
unusedOffPathAwayFromLink :: Float -> PlacementSpot
|
||||
unusedOffPathAwayFromLink x = PSPos f (const id) Nothing
|
||||
where
|
||||
f rp r = case rp of
|
||||
UnusedSpot p a t
|
||||
| all ( (>x) . dist p ) (usedRoomLinkPoss r) && RoomPosOffPath `S.member` t
|
||||
-> Just (PS p a,UsedSpot p a t)
|
||||
_ -> Nothing
|
||||
|
||||
unusedSpotAwayFromInLink :: Float -> PlacementSpot
|
||||
unusedSpotAwayFromInLink x = PSPos f (const id) Nothing
|
||||
where
|
||||
f rp r = case rp of
|
||||
UnusedSpot p a | all ( (>x) . dist p ) inlinkposs -> Just (PS p a,UsedSpot p a)
|
||||
UnusedSpot p a t | all ( (>x) . dist p ) (usedRoomInLinkPoss r) -> Just (PS p a,UsedSpot p a t)
|
||||
_ -> Nothing
|
||||
where
|
||||
inlinkposs = usedRoomInLinkPoss r
|
||||
|
||||
twoUnusedLinks :: (PlacementSpot -> PlacementSpot -> Placement)
|
||||
-> Placement
|
||||
twoUnusedLinks f = Placement useUnusedLink PutNothing Nothing
|
||||
$ \pl1 -> Just $ Placement useUnusedLink PutNothing Nothing
|
||||
$ \pl2 -> Just $ f (_plSpot pl1) (_plSpot pl2)
|
||||
|
||||
twoRoomPoss :: (RoomPos -> Bool)
|
||||
-> (RoomPos -> Bool)
|
||||
-> (PlacementSpot -> PlacementSpot -> Placement)
|
||||
-> Placement
|
||||
twoRoomPoss cond1 cond2 f = Placement (useRoomPos cond1) PutNothing Nothing
|
||||
$ \pl1 -> Just $ Placement (useRoomPos cond2) PutNothing Nothing
|
||||
$ \pl2 -> Just $ f (_plSpot pl1) (_plSpot pl2)
|
||||
|
||||
useUnusedLink :: PlacementSpot
|
||||
useUnusedLink = PSPos unusedLnkToPS (const id) Nothing
|
||||
|
||||
useRoomPos :: (RoomPos -> Bool) -> PlacementSpot
|
||||
useRoomPos cond = PSPos (useRoomPosCond cond) (const id) Nothing
|
||||
|
||||
useRoomPosCond :: (RoomPos -> Bool)
|
||||
-> RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)
|
||||
useRoomPosCond t rp _
|
||||
| t rp = Just (PS p a, UsedSpot p a (fromMaybe S.empty $ rp ^? rpType))
|
||||
| otherwise = Nothing
|
||||
where
|
||||
p = _rpPos rp
|
||||
a = _rpDir rp
|
||||
|
||||
unusedLnkToPS :: RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)
|
||||
unusedLnkToPS = useRoomPosCond $ \rp -> case rp of
|
||||
UnusedLink {} -> True
|
||||
_ -> False
|
||||
|
||||
isUnusedLinkType :: RoomLinkType -> RoomPos -> Bool
|
||||
isUnusedLinkType rlt rp = case rp of
|
||||
UnusedLink{_rpLinkType = rlts} -> rlt `S.member` rlts
|
||||
_ -> False
|
||||
|
||||
unusedSpotNearInLink :: Float -> PlacementSpot
|
||||
unusedSpotNearInLink x = PSPos f (const id) Nothing
|
||||
where
|
||||
f rp r = case rp of
|
||||
UnusedSpot p a | any ( (<x) . dist p ) inlinkposs -> Just (PS p a,UsedSpot p a)
|
||||
UnusedSpot p a t | any ( (<x) . dist p ) (usedRoomInLinkPoss r) -> Just (PS p a,UsedSpot p a t)
|
||||
_ -> Nothing
|
||||
where
|
||||
inlinkposs = usedRoomInLinkPoss r
|
||||
|
||||
usedRoomInLinkPoss :: Room -> [Point2]
|
||||
usedRoomInLinkPoss r = mapMaybe f $ _rmPos r
|
||||
@@ -44,23 +106,31 @@ usedRoomInLinkPoss r = mapMaybe f $ _rmPos r
|
||||
UsedInLink {} -> Just $ _rpPos rp
|
||||
_ -> Nothing
|
||||
|
||||
usedRoomLinkPoss :: Room -> [Point2]
|
||||
usedRoomLinkPoss r = mapMaybe f $ _rmPos r
|
||||
where
|
||||
f rp = case rp of
|
||||
UsedInLink {} -> Just $ _rpPos rp
|
||||
UsedOutLink {} -> Just $ _rpPos rp
|
||||
_ -> Nothing
|
||||
|
||||
-- TODO rename to any unused link facing out
|
||||
anyLnkOutPS :: PlacementSpot
|
||||
anyLnkOutPS = PSPos f (const id) Nothing
|
||||
where
|
||||
f (UnusedLink p a) _ = Just (PS p a, UsedSpot p a)
|
||||
f (UnusedLink p a _) _ = Just (PS p a, UsedSpot p a S.empty)
|
||||
f _ _ = Nothing
|
||||
|
||||
atFstLnkOut :: PlacementSpot
|
||||
atFstLnkOut = PSPos f (const id) Nothing
|
||||
where
|
||||
f (UsedOutLink 0 i p a) _ = Just (PS p a, UsedOutLink 0 i p a)
|
||||
f (UsedOutLink 0 i p a lt) _ = Just (PS p a, UsedOutLink 0 i p a lt)
|
||||
f _ _ = Nothing
|
||||
|
||||
atNthLnkOutShiftBy :: Int -> ((Point2,Float) -> (Point2,Float)) -> PlacementSpot
|
||||
atNthLnkOutShiftBy n theshift = PSPos f (const id) Nothing
|
||||
where
|
||||
f (UsedOutLink i rmid p a) _ | n == i = Just (PS p' a', UsedOutLink n rmid p a)
|
||||
f (UsedOutLink i rmid p a lt) _ | n == i = Just (PS p' a', UsedOutLink n rmid p a lt)
|
||||
where
|
||||
(p',a') = theshift (p,a)
|
||||
f _ _ = Nothing
|
||||
@@ -79,14 +149,14 @@ atNthLnkOutShiftInward n x = atNthLnkOutShiftBy n f
|
||||
overFstLnkOut :: PlacementSpot
|
||||
overFstLnkOut = PSPos f (const id) Nothing
|
||||
where
|
||||
f (UsedOutLink 0 _ p a) _ = Just (PS p a, UsedSpot p a)
|
||||
f (UsedOutLink 0 _ p a lt) _ = Just (PS p a, UsedLink p a lt)
|
||||
f _ _ = Nothing
|
||||
|
||||
anyLnkInPS :: Float -- ^ amount to shift inward
|
||||
-> PlacementSpot
|
||||
anyLnkInPS x = PSPos f (const id) Nothing
|
||||
where
|
||||
f (UnusedLink v a) _ = Just (PS v' a' ,UsedSpot v' a')
|
||||
f (UnusedLink v a _) _ = Just (PS v' a' ,UsedSpot v' a' S.empty)
|
||||
where
|
||||
v' = v -.- x *.* unitVectorAtAngle (a + 0.5 * pi)
|
||||
a' = a + pi
|
||||
@@ -94,7 +164,7 @@ anyLnkInPS x = PSPos f (const id) Nothing
|
||||
|
||||
useLnkRoomPos :: RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)
|
||||
useLnkRoomPos rp _ = case rp of
|
||||
(UnusedLink (V2 x y) a) -> Just (PS (V2 x y) a , UsedSpot (V2 x y) a)
|
||||
(UnusedLink (V2 x y) a lt) -> Just (PS (V2 x y) a , UsedLink (V2 x y) a lt)
|
||||
_ -> Nothing
|
||||
|
||||
psRandRanges :: (Float,Float) -> (Float,Float) -> (Float,Float) -> State StdGen (Point2,Float)
|
||||
|
||||
@@ -18,6 +18,7 @@ module Dodge.Room
|
||||
, module Dodge.Room.Boss
|
||||
, module Dodge.Room.Treasure
|
||||
, module Dodge.Room.GlassLesson
|
||||
, module Dodge.Room.Tanks
|
||||
) where
|
||||
import Dodge.Room.Room
|
||||
import Dodge.Room.RoadBlock
|
||||
@@ -37,3 +38,4 @@ import Dodge.Room.Airlock
|
||||
import Dodge.Room.LongDoor
|
||||
import Dodge.Room.LongRoom
|
||||
import Dodge.Room.GlassLesson
|
||||
import Dodge.Room.Tanks
|
||||
|
||||
@@ -118,8 +118,8 @@ addButtonSlowDoor x h rm = do
|
||||
aboveH y = (sndV2 . fst) y > h + 40
|
||||
butDoor _ _ = putLitButOnPos col butPosCond
|
||||
$ \btid -> Just $ putDoubleDoor False col (cond' btid) (V2 0 h) (V2 x h) 2
|
||||
butPosCond (UnusedLink (V2 x' y') a') _ | y' < 0.5 * h
|
||||
= Just (PS (V2 x' y') a' , UsedSpot (V2 x' y') a')
|
||||
butPosCond (UnusedLink (V2 x' y') a' _) _ | y' < 0.5 * h
|
||||
= Just (PS (V2 x' y') a' , UsedSpot (V2 x' y') a' (S.singleton RoomPosExLink))
|
||||
butPosCond _ _ = Nothing
|
||||
--butPosCond _ = True -- y < h
|
||||
col = dim $ light red
|
||||
|
||||
@@ -4,6 +4,7 @@ module Dodge.Room.Procedural
|
||||
( roomRect
|
||||
, roomRectAutoLinks
|
||||
, randomFourCornerRoom
|
||||
, randomFourCornerRoomCrsIts
|
||||
, centerVaultRoom
|
||||
, combineRooms
|
||||
, linksAndPath
|
||||
@@ -32,11 +33,13 @@ import Geometry
|
||||
import Picture
|
||||
import Data.Tile
|
||||
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
import Control.Lens
|
||||
import Control.Monad
|
||||
import Control.Monad.State
|
||||
import System.Random
|
||||
-- This will need a cleanup, but it might change a bit first
|
||||
{- A simple rectangular room with a light in the center.
|
||||
Creates links and pathfinding graph. -}
|
||||
roomRect
|
||||
@@ -49,7 +52,8 @@ roomRect x y xn yn = defaultRoom
|
||||
{ _rmPolys = [rectNSWE y 0 0 x ]
|
||||
, _rmLinks = lnks
|
||||
, _rmPath = concatMap doublePair pth
|
||||
, _rmPos = map (`UnusedSpot` 0) posps
|
||||
, _rmPos = map (\pd -> UnusedSpot pd 0 $ S.singleton RoomPosOnPath) posps
|
||||
++ map (\pd -> UnusedSpot pd 0 $ S.singleton RoomPosOffPath) interposps
|
||||
, _rmPmnts = []
|
||||
, _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)]
|
||||
, _rmFloor = Tiled [Tile
|
||||
@@ -67,10 +71,14 @@ roomRect x y xn yn = defaultRoom
|
||||
wlnks = zip (map (+.+ V2 x 20) $ gridPoints 0 1 yd (yn+1)) (repeat (-pi/2))
|
||||
nlnks = zip (map (+.+ V2 20 y) $ gridPoints xd (xn+1) 0 1 ) (repeat 0 )
|
||||
slnks = zip (map (+.+ V2 20 0) $ gridPoints xd (xn+1) 0 1 ) (repeat pi )
|
||||
lnks = m North nlnks ++ m East elnks ++ m West wlnks ++ m South slnks
|
||||
m edge = map (lnkBothAnd (OnEdge edge))
|
||||
lnks = zipWith (m North FromWest) [0..] nlnks
|
||||
++ zipWith (m East FromSouth) [0..] elnks
|
||||
++ zipWith (m West FromSouth) [0..] wlnks
|
||||
++ zipWith (m South FromWest) [0..] slnks
|
||||
m edge = lnkBothAnd' (OnEdge edge)
|
||||
pth = linksAndPath' lnks $ map (bimap (+.+ V2 20 20) (+.+ V2 20 20)) (makeGrid xd xn yd yn)
|
||||
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
|
||||
{- Creates a rectangular room, automatically creates links and pathfinding graph at a sensible size. -}
|
||||
-- it is not clear to me that this works for very small rooms (but it does seem
|
||||
-- to do so)
|
||||
@@ -80,7 +88,8 @@ roomRectAutoLinks x y = (roomRect x y xn yn)
|
||||
where
|
||||
xn = max 1 $ (ceiling x - 40) `div` 60
|
||||
yn = max 1 $ (ceiling y - 40) `div` 60
|
||||
plmnts = [mntLightLnkCond unusedLnkToPS ]
|
||||
plmnts = [mntLightLnkCond unusedLnkToPS
|
||||
, mntLightLnkCond unusedLnkToPS ]
|
||||
{- Combines two rooms into one room.
|
||||
- will have to work out exactly what to do with combining links
|
||||
Mostly involves concatenation. -}
|
||||
@@ -193,9 +202,10 @@ fillNothingPlacements pst r = foldr fillNothingPlacement r pst
|
||||
{- | Randomise the ordering of placements in a room.
|
||||
Useful for randomising the position of generic placements such as 'PutNothing'. -}
|
||||
shufflePlacements :: RandomGen g => Room -> State g Room
|
||||
shufflePlacements r = do
|
||||
newPSs <- shuffle $ _rmPmnts r
|
||||
return $ r & rmPmnts .~ newPSs
|
||||
shufflePlacements = rmPmnts shuffle
|
||||
--shufflePlacements r = do
|
||||
-- newPSs <- shuffle $ _rmPmnts r
|
||||
-- return $ r & rmPmnts .~ newPSs
|
||||
{- | A randomly generate room based on four randomly generated corners.
|
||||
Tight corridors, random placements. -}
|
||||
randomFourCornerRoom :: RandomGen g => [Item] -> State g Room
|
||||
@@ -211,6 +221,18 @@ randomFourCornerRoom its = do
|
||||
. foldr1 combineRooms
|
||||
$ zipWith (\r a -> moveRoomBy (V2 0 0,a) r) corners [0,pi/2,pi,3*pi/2]
|
||||
)
|
||||
{- | A randomly generate room based on four randomly generated corners.
|
||||
Tight corridors. -}
|
||||
randomFourCornerRoomCrsIts :: RandomGen g => [Creature] -> [Item] -> State g Room
|
||||
randomFourCornerRoomCrsIts crits its = do
|
||||
corners <- replicateM 4 . join $ takeOne [quarterRoomTri 100, quarterRoomSquare 100]
|
||||
itms <- shuffle its
|
||||
randomiseAllLinks . fillNothingPlacements (map PutCrit crits ++ map PutFlIt itms) =<<
|
||||
( shufflePlacements
|
||||
. over rmPmnts ( sps0 putLamp :)
|
||||
. foldr1 combineRooms
|
||||
$ zipWith (\r a -> moveRoomBy (V2 0 0,a) r) corners [0,pi/2,pi,3*pi/2]
|
||||
)
|
||||
{- | Creates room with a central vault with doors around it. -}
|
||||
centerVaultRoom
|
||||
:: Float -- ^ Width
|
||||
|
||||
@@ -24,6 +24,7 @@ import Tile
|
||||
import MonadHelp
|
||||
import LensHelp
|
||||
|
||||
import qualified Data.Set as S
|
||||
import Control.Monad.State
|
||||
--import Control.Monad.Loops
|
||||
import System.Random
|
||||
@@ -82,7 +83,7 @@ glassSwitchBack = do
|
||||
hgt <- state $ randomR (400,600)
|
||||
wllen <- state $ randomR (60,wth/2-40)
|
||||
let hf = hgt/5
|
||||
con1 cond (UnusedLink (V2 x y) a) _ | cond y = Just (PS (V2 x y) a , UsedSpot (V2 x y) a)
|
||||
con1 cond (UnusedLink (V2 x y) a _) _ | cond y = Just (PS (V2 x y) a , UsedSpot (V2 x y) a $ S.singleton RoomPosExLink)
|
||||
con1 _ _ _ = Nothing
|
||||
plmnts =
|
||||
[ mntLightLnkCond $ con1 (< 0.5 * hgt)
|
||||
|
||||
+13
-18
@@ -1,7 +1,9 @@
|
||||
module Dodge.Room.Start where
|
||||
import Dodge.Data
|
||||
import Dodge.LevelGen.Data
|
||||
--import Dodge.PlacementSpot
|
||||
import Dodge.Room.RunPast
|
||||
import Dodge.Room.Tanks
|
||||
--import Dodge.RoomLink
|
||||
--import Dodge.Data
|
||||
--import Dodge.Default
|
||||
@@ -14,18 +16,13 @@ import Dodge.Room.Corridor
|
||||
import Dodge.Room.Room
|
||||
import Dodge.Room.Link
|
||||
import Dodge.Room.Procedural
|
||||
import Dodge.Room.Foreground
|
||||
--import Dodge.Room.RoadBlock
|
||||
import Dodge.Placement.Instance
|
||||
--import Dodge.Item.Random
|
||||
import Dodge.Item.Weapon.BulletGuns
|
||||
import Dodge.Item.Weapon.Utility
|
||||
import Dodge.Item.Craftable
|
||||
--import Dodge.LevelGen.Data
|
||||
--import Geometry.Data
|
||||
import Geometry
|
||||
--import Padding
|
||||
import Color
|
||||
import Shape
|
||||
--import Shape
|
||||
import LensHelp
|
||||
|
||||
--import Data.Maybe
|
||||
@@ -90,18 +87,16 @@ rezBoxThenWeaponRoom = do
|
||||
rcol <- rezColor
|
||||
treeFromTrunk [PassDown $ rezBox rcol,PassDown door] <$> weaponRoom
|
||||
|
||||
startCrafts :: RandomGen g => State g [Item]
|
||||
startCrafts = takeOne $ map (map makeTypeCraft)
|
||||
[ [PIPE,PIPE,HARDWARE]
|
||||
, [TUBE,PIPE,HARDWARE]
|
||||
]
|
||||
|
||||
startRoom' :: RandomGen g => State g (SubCompTree Room)
|
||||
startRoom' = do
|
||||
w <- state $ randomR (100,400)
|
||||
h <- state $ randomR (200,400)
|
||||
let plmnts =
|
||||
[ sPS (V2 0 0) 0 $ PutShape $ girderV 40 20 10 (V2 0 (h/2)) (V2 w (h/2))
|
||||
-- , mntLS jShape (V2 0 (h/3)) (V3 40 (h/3) 70)
|
||||
, tankSquareEmboss4 (dim orange) 50 (h-60)
|
||||
, tankSquare (dim orange) 50 50
|
||||
, tankSquare (dim orange) 50 120
|
||||
, sps0 $ PutShape $ colorSH orange $ pipePP 2 (V3 50 50 25) (V3 50 120 25)
|
||||
]
|
||||
scrafts <- startCrafts
|
||||
troom <- tanksRoom [] scrafts
|
||||
thecol <- rezColor
|
||||
treeFromPost [PassDown $ rezBox thecol, PassDown door] . UseAll
|
||||
<$> shuffleLinks (roomRectAutoLinks w h & rmPmnts .++~ plmnts)
|
||||
<$> shuffleLinks troom
|
||||
|
||||
@@ -0,0 +1,48 @@
|
||||
module Dodge.Room.Tanks where
|
||||
import Dodge.Data
|
||||
import Dodge.LevelGen.Data
|
||||
import Dodge.RandomHelp
|
||||
import Dodge.Room.Procedural
|
||||
import Dodge.Room.Foreground
|
||||
--import Dodge.Room.RoadBlock
|
||||
import Dodge.Placement.Instance
|
||||
import Dodge.PlacementSpot
|
||||
--import Padding
|
||||
import Color
|
||||
--import Shape
|
||||
import LensHelp
|
||||
|
||||
--import Data.Maybe
|
||||
--import Data.Tree
|
||||
import Control.Monad.State
|
||||
import System.Random
|
||||
import qualified Data.Set as S
|
||||
|
||||
randomTank :: RandomGen g => State g Placement
|
||||
randomTank = takeOne $ map (\f -> f (dim orange) orange)
|
||||
[ tankSquareEmboss4
|
||||
, tankSquareEmboss
|
||||
, tankSquare
|
||||
, roundTank
|
||||
, roundTankCross
|
||||
, tankSquareCross
|
||||
]
|
||||
|
||||
tanksRoom :: RandomGen g => [Creature] -> [Item] -> State g Room
|
||||
tanksRoom crs its = do
|
||||
w <- state $ randomR (100,400)
|
||||
h <- state $ randomR (200,400)
|
||||
ntanks <- state $ randomR (3,6)
|
||||
thetank <- randomTank <&> plSpot .~ unusedOffPathAwayFromLink 50
|
||||
let room = roomRectAutoLinks w h
|
||||
nwestlnks = length $ filter ((OnEdge West `S.member`) . _rlType) $ _rmLinks room
|
||||
let plmnts =
|
||||
--[ twoRoomPoss (isUnusedLinkType (OnEdge West)) (isUnusedLinkType (OnEdge East)) $ \ps1 ps2 ->
|
||||
[ twoRoomPoss (isUnusedLinkType (FromSouth i)) (isUnusedLinkType (FromSouth i)) $ \ps1 ps2 ->
|
||||
sps0 $ PutShape $ girderV 96 20 10 (_psPos ps1) (_psPos ps2)
|
||||
| i <- [1 .. nwestlnks - 2]]
|
||||
++ map (\it -> sps0 (PutFlIt it) & plSpot .~ anyUnusedSpot) its
|
||||
++ map (\cr -> sps0 (PutCrit cr) & plSpot .~ unusedSpotAwayFromLink 50) crs
|
||||
++ replicate ntanks thetank
|
||||
-- , sps0 $ PutShape $ colorSH orange $ pipePP 2 (V3 50 50 25) (V3 50 120 25)
|
||||
return $ room & rmPmnts .++~ plmnts
|
||||
@@ -100,6 +100,13 @@ lnkBothAnd rlt (p,a) = RoomLink
|
||||
, _rlDir = a
|
||||
}
|
||||
|
||||
lnkBothAnd' :: RoomLinkType -> (Int -> RoomLinkType) -> Int -> (Point2,Float) -> RoomLink
|
||||
lnkBothAnd' rlt ltcon i (p,a) = RoomLink
|
||||
{_rlType = S.fromList [OutLink,InLink,rlt,ltcon i]
|
||||
,_rlPos = p
|
||||
, _rlDir = a
|
||||
}
|
||||
|
||||
toBothLnk :: (Point2,Float) -> RoomLink
|
||||
toBothLnk (p,a) = RoomLink
|
||||
{_rlType = S.fromList [OutLink,InLink]
|
||||
|
||||
+20
-3
@@ -67,20 +67,37 @@ posRms bounds parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do
|
||||
clipping = or (convexPolysOverlap <$> newBounds <*> bounds)
|
||||
updateparent rm = doLnkEff (lnkPosDir outlnk) $ rm
|
||||
& rmLinks %~ delete outlnk
|
||||
& rmPos .:~ uncurry (UsedOutLink numChild (snd childi)) (lnkPosDir outlnk)
|
||||
& rmPos .:~ UsedOutLink
|
||||
{ _rpChildNum = numChild
|
||||
, _rpOutRoomID = snd childi
|
||||
, _rpPos = fst (lnkPosDir outlnk)
|
||||
, _rpDir = snd (lnkPosDir outlnk)
|
||||
, _rpLinkType = _rlType outlnk
|
||||
}
|
||||
& rmChildren .:~ snd childi
|
||||
shiftedoutlink = shiftLinkBy (_rmShift parent) outlnk
|
||||
updatechild rm = rm
|
||||
& rmMParent ?~ snd parenti
|
||||
& rmMID ?~ snd childi
|
||||
& rmLinks %~ delete il
|
||||
& rmPos .:~ uncurry (UsedInLink 0) (lnkPosDir il)
|
||||
& rmPos .:~ UsedInLink
|
||||
{ _rpInRoomID = 0
|
||||
, _rpPos = fst (lnkPosDir il)
|
||||
, _rpDir = snd (lnkPosDir il)
|
||||
, _rpLinkType = _rlType il
|
||||
}
|
||||
shiftedt = applyToRoot
|
||||
(first $ updatechild . shiftRoomShiftToLink (lnkPosDir shiftedoutlink) (lnkPosDir il))
|
||||
t
|
||||
|
||||
createUnusedLinkPos :: Room -> Room
|
||||
createUnusedLinkPos rm = rm & rmPos .++~ map (uncurry UnusedLink . lnkPosDir) (_rmLinks rm)
|
||||
createUnusedLinkPos rm = rm & rmPos .++~ map f (_rmLinks rm)
|
||||
where
|
||||
f rl = UnusedLink
|
||||
{ _rpPos = _rlPos rl
|
||||
, _rpDir = _rlDir rl
|
||||
, _rpLinkType = _rlType rl
|
||||
}
|
||||
|
||||
zipCount :: [a] -> [(Int,a)]
|
||||
zipCount = Prelude.zip [0..]
|
||||
|
||||
Reference in New Issue
Block a user