From ff6064a3b6deb2ccc26e48d4063eeb2e0877db88 Mon Sep 17 00:00:00 2001 From: justin Date: Tue, 8 Mar 2022 22:57:58 +0000 Subject: [PATCH] Add rooms, placements and room positions --- src/Dodge/Layout.hs | 12 +- src/Dodge/LevelGen/Data.hs | 27 ++++- src/Dodge/LockAndKey.hs | 38 +++++-- src/Dodge/Placement/Instance/LightSource.hs | 7 -- src/Dodge/Placement/Instance/Tank.hs | 119 +++++++++----------- src/Dodge/PlacementSpot.hs | 96 +++++++++++++--- src/Dodge/Room.hs | 2 + src/Dodge/Room/LongDoor.hs | 4 +- src/Dodge/Room/Procedural.hs | 36 ++++-- src/Dodge/Room/Room.hs | 3 +- src/Dodge/Room/Start.hs | 31 +++-- src/Dodge/Room/Tanks.hs | 48 ++++++++ src/Dodge/RoomLink.hs | 7 ++ src/Dodge/Tree/Shift.hs | 23 +++- 14 files changed, 315 insertions(+), 138 deletions(-) create mode 100644 src/Dodge/Room/Tanks.hs diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index be1cce431..d6da7cc72 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -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 diff --git a/src/Dodge/LevelGen/Data.hs b/src/Dodge/LevelGen/Data.hs index c5eec08fb..83e70cafe 100644 --- a/src/Dodge/LevelGen/Data.hs +++ b/src/Dodge/LevelGen/Data.hs @@ -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 diff --git a/src/Dodge/LockAndKey.hs b/src/Dodge/LockAndKey.hs index c0a5d16dd..02efa5911 100644 --- a/src/Dodge/LockAndKey.hs +++ b/src/Dodge/LockAndKey.hs @@ -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) diff --git a/src/Dodge/Placement/Instance/LightSource.hs b/src/Dodge/Placement/Instance/LightSource.hs index 4faff2ad4..ac699782c 100644 --- a/src/Dodge/Placement/Instance/LightSource.hs +++ b/src/Dodge/Placement/Instance/LightSource.hs @@ -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 diff --git a/src/Dodge/Placement/Instance/Tank.hs b/src/Dodge/Placement/Instance/Tank.hs index 5a5414b1c..303bfc9ab 100644 --- a/src/Dodge/Placement/Instance/Tank.hs +++ b/src/Dodge/Placement/Instance/Tank.hs @@ -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 diff --git a/src/Dodge/PlacementSpot.hs b/src/Dodge/PlacementSpot.hs index cb1a7a919..fcf12f295 100644 --- a/src/Dodge/PlacementSpot.hs +++ b/src/Dodge/PlacementSpot.hs @@ -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 ( ( Just (PS p a,UsedSpot p a) + UnusedSpot p a t | any ( ( 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) diff --git a/src/Dodge/Room.hs b/src/Dodge/Room.hs index 6dab6a243..ca496a139 100644 --- a/src/Dodge/Room.hs +++ b/src/Dodge/Room.hs @@ -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 diff --git a/src/Dodge/Room/LongDoor.hs b/src/Dodge/Room/LongDoor.hs index 1d39483f9..f57ee19a3 100644 --- a/src/Dodge/Room/LongDoor.hs +++ b/src/Dodge/Room/LongDoor.hs @@ -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 diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs index 89ad720b5..5d914af90 100644 --- a/src/Dodge/Room/Procedural.hs +++ b/src/Dodge/Room/Procedural.hs @@ -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 diff --git a/src/Dodge/Room/Room.hs b/src/Dodge/Room/Room.hs index f456f924c..8fda26bb5 100644 --- a/src/Dodge/Room/Room.hs +++ b/src/Dodge/Room/Room.hs @@ -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) diff --git a/src/Dodge/Room/Start.hs b/src/Dodge/Room/Start.hs index f8bb49177..f3ec89838 100644 --- a/src/Dodge/Room/Start.hs +++ b/src/Dodge/Room/Start.hs @@ -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 diff --git a/src/Dodge/Room/Tanks.hs b/src/Dodge/Room/Tanks.hs new file mode 100644 index 000000000..0ab55775d --- /dev/null +++ b/src/Dodge/Room/Tanks.hs @@ -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 diff --git a/src/Dodge/RoomLink.hs b/src/Dodge/RoomLink.hs index 77c5bed73..8d9d41ed7 100644 --- a/src/Dodge/RoomLink.hs +++ b/src/Dodge/RoomLink.hs @@ -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] diff --git a/src/Dodge/Tree/Shift.hs b/src/Dodge/Tree/Shift.hs index dce7808e3..864568ca9 100644 --- a/src/Dodge/Tree/Shift.hs +++ b/src/Dodge/Tree/Shift.hs @@ -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..]