From e44c5e71202fa8aa8f49bffd172fd4103ffaa79e Mon Sep 17 00:00:00 2001 From: justin Date: Wed, 24 Nov 2021 20:51:50 +0000 Subject: [PATCH] Allow for more complex placement positioning --- src/Dodge/Default/Room.hs | 2 + src/Dodge/LevelGen/Data.hs | 29 ++++-- src/Dodge/LockAndKey.hs | 6 +- src/Dodge/Placement/Instance/Button.hs | 4 +- src/Dodge/Placement/Instance/LightSource.hs | 10 +- src/Dodge/Placement/PlaceSpot.hs | 13 +-- src/Dodge/PlacementSpot.hs | 46 ++++++--- src/Dodge/Room/Link.hs | 12 +++ src/Dodge/Room/LongDoor.hs | 21 +++- src/Dodge/Room/Procedural.hs | 7 +- src/Dodge/Room/RoadBlock.hs | 10 +- src/Dodge/Room/Room.hs | 40 ++++---- src/Dodge/Room/Start.hs | 103 ++------------------ src/Dodge/RoomLink.hs | 36 +++++-- src/Dodge/Tree/Compose.hs | 5 + src/Dodge/Tree/Shift.hs | 7 +- 16 files changed, 178 insertions(+), 173 deletions(-) diff --git a/src/Dodge/Default/Room.hs b/src/Dodge/Default/Room.hs index 0882f5762..0bfb3365b 100644 --- a/src/Dodge/Default/Room.hs +++ b/src/Dodge/Default/Room.hs @@ -3,6 +3,7 @@ module Dodge.Default.Room import Geometry.Data import Dodge.LevelGen.Data import qualified Data.IntMap.Strict as IM +import qualified Data.Set as S defaultRoom :: Room defaultRoom = Room @@ -24,4 +25,5 @@ defaultRoom = Room , _rmTakeFrom = Nothing , _rmStartWires = IM.empty , _rmEndWires = IM.empty + , _rmConnectsTo = S.singleton OutLink } diff --git a/src/Dodge/LevelGen/Data.hs b/src/Dodge/LevelGen/Data.hs index c805964a7..20eb23da5 100644 --- a/src/Dodge/LevelGen/Data.hs +++ b/src/Dodge/LevelGen/Data.hs @@ -38,11 +38,14 @@ data PSType = PutCrit {_unPutCrit :: Creature} data PlacementSpot = PS { _psPos :: Point2 , _psRot :: Float } | PSPos - { _psLnkShift :: RoomPos -> Maybe (PlacementSpot, RoomPos) - , _psLnkRoomEff :: RoomPos -> Room -> Room - , _psLnkFallback :: Maybe Placement + { _psSelect :: RoomPos -> Room -> Maybe (PlacementSpot, RoomPos) + , _psRoomEff :: RoomPos -> Room -> Room + , _psFallback :: Maybe Placement + } + | PSRoomRand + { _psRoomRandPointNum :: Int + , _psRandShift :: (Point2,Float) -> PlacementSpot } - | PSRoomRand { _psRoomRandPointNum :: Int } data Placement = Placement { _plSpot :: PlacementSpot , _plType :: PSType @@ -82,6 +85,7 @@ data Room = Room , _rmTakeFrom :: Maybe Int , _rmStartWires :: IM.IntMap RoomWire , _rmEndWires :: IM.IntMap RoomWire + , _rmConnectsTo :: S.Set RoomLinkType } data RoomLink = RoomLink { _rlType :: S.Set RoomLinkType @@ -92,6 +96,13 @@ data RoomLinkType = OutLink | InLink | LabLink Int + | OnEdge CardinalPoint + deriving (Eq,Ord) +data CardinalPoint + = North + | East + | South + | West deriving (Eq,Ord) data RoomWire = --RoomWire Point2 Float @@ -112,9 +123,13 @@ data RoomPos {_rpPos :: Point2 ,_rpDir ::Float } - | PosPl + | UsedSpot {_rpPos :: Point2 - ,_rpDir ::Float + ,_rpDir :: Float + } + | UnusedSpot + {_rpPos :: Point2 + ,_rpDir :: Float } deriving (Eq,Ord,Show) @@ -144,7 +159,7 @@ sps :: PlacementSpot -> PSType -> Placement sps ps pt = Placement ps pt Nothing (const Nothing) plRRpt :: Int -> PSType -> Placement -plRRpt i pt = Placement (PSRoomRand i) pt Nothing (const Nothing) +plRRpt i pt = Placement (PSRoomRand i (uncurry PS)) pt Nothing (const Nothing) jsps :: Point2 -> Float -> PSType -> Maybe Placement jsps p a pst = Just $ Placement (PS p a) pst Nothing $ const Nothing diff --git a/src/Dodge/LockAndKey.hs b/src/Dodge/LockAndKey.hs index f49adf658..17d29b37c 100644 --- a/src/Dodge/LockAndKey.hs +++ b/src/Dodge/LockAndKey.hs @@ -15,14 +15,14 @@ import Control.Monad.State lockRoomKeyItems :: RandomGen g => [ (Int -> State g (SubCompTree Room) , State g ItemIdentity ) ] lockRoomKeyItems = - [ (lasCenSensEdge, takeOne [Launcher] ) --- , (const $ fmap singleUseAll slowDoorRoom, return MiniGun) + [(lasCenSensEdge, takeOne [Launcher] ) + ,(const slowDoorRoomRunPast, return MiniGun) ] itemRooms :: RandomGen g => [(ItemIdentity, State g (SubCompTree Room))] itemRooms = [ (Launcher , corridorBoss launcherCrit ) - -- , (MiniGun , join $ takeOne [roomMiniIntro, minigunFakeout] ) + , (MiniGun , join $ takeOne [roomMiniIntro, minigunFakeout] ) ] corridorBoss :: RandomGen g => Creature -> State g (SubCompTree Room) diff --git a/src/Dodge/Placement/Instance/Button.hs b/src/Dodge/Placement/Instance/Button.hs index 70ed8abb2..63a2e0d1a 100644 --- a/src/Dodge/Placement/Instance/Button.hs +++ b/src/Dodge/Placement/Instance/Button.hs @@ -58,7 +58,7 @@ putLitButtonID col p a subpl = mntLSOn aShape (Just col) ls p'' (addZ 40 p') ls = defaultLS { _lsRad = 75 , _lsIntensity = V3 0.5 0 0 } putLitButOnPos :: Color - -> (RoomPos -> Maybe (PlacementSpot,RoomPos)) + -> (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)) -> (Int -> Maybe Placement) -> Placement putLitButOnPos col f subpl = plSpot .~ thePS $ mntLSOn aShape (Just col) ls 0 (V3 0 (-40) 40) @@ -89,7 +89,7 @@ extTrigLitPos ps f = psPtCont ps (PutTrigger (const False)) thels = defaultLS {_lsIntensity = V3 0.5 0 0, _lsPos = V3 0 0 78, _lsRad = 75} putLitButOnPosExtTrig :: Color - -> (RoomPos -> Maybe (PlacementSpot,RoomPos)) + -> (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)) -> Placement putLitButOnPosExtTrig col f = psPtCont thePS (PutTrigger (const False)) diff --git a/src/Dodge/Placement/Instance/LightSource.hs b/src/Dodge/Placement/Instance/LightSource.hs index 6823e4e35..e58e6d258 100644 --- a/src/Dodge/Placement/Instance/LightSource.hs +++ b/src/Dodge/Placement/Instance/LightSource.hs @@ -81,7 +81,7 @@ mntLS :: (Point2 -> Point3 -> Shape) -> Point2 -> Point3 -> Placement mntLS shp wallp lampp = mntLSOn shp Nothing defaultLS wallp lampp (const Nothing) mntLSCond :: (Point2 -> Point3 -> Shape) - -> (RoomPos -> Maybe (PlacementSpot,RoomPos)) + -> (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)) -> Placement mntLSCond shp shift = -- updatePSToLevel 1 (const $ PSLnk shift (const id) Nothing) $ mntLS shp 0 (V3 0 (-40) 90) @@ -93,15 +93,15 @@ mntLight a b = RandomPlacement $ do shp <- takeOne [vShape,iShape,lShape,jShape,liShape] return $ mntLS shp a (addZ 90 b) -mntLightLnkCond :: (RoomPos -> Maybe (PlacementSpot,RoomPos)) +mntLightLnkCond :: (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)) -> Placement mntLightLnkCond f = RandomPlacement $ do shp <- takeOne [vShape,iShape,lShape,jShape,liShape] return $ mntLSCond shp f -unusedLnkToPS :: RoomPos -> Maybe (PlacementSpot,RoomPos) -unusedLnkToPS rp = case rp of - UnusedLink p a -> Just (PS p a,PosPl p a) +unusedLnkToPS :: RoomPos -> Room -> Maybe (PlacementSpot,RoomPos) +unusedLnkToPS rp _ = case rp of + UnusedLink p a -> Just (PS p a,UsedSpot p a) _ -> Nothing spanLSLightI :: LightSource -> Float -> Point2 -> Point2 -> Placement diff --git a/src/Dodge/Placement/PlaceSpot.hs b/src/Dodge/Placement/PlaceSpot.hs index 8171cbb10..7e943c122 100644 --- a/src/Dodge/Placement/PlaceSpot.hs +++ b/src/Dodge/Placement/PlaceSpot.hs @@ -33,7 +33,7 @@ import Data.Bifunctor -- to the placement placeSpot :: (World,Room) -> Placement -> ( (World,Room), [Placement] ) placeSpot (w,rm) plmnt = case plmnt of - Placement{_plSpot = PSRoomRand i} -> placeSpotRoomRand rm i plmnt w + Placement{_plSpot = PSRoomRand i f} -> placeSpotRoomRand rm i f plmnt w Placement{_plSpot = PSPos extract eff fallback} -> placeSpotUsingLink w rm plmnt extract eff fallback Placement{} -> let (i,w') = placeSpotID (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w @@ -52,7 +52,7 @@ placeSpot (w,rm) plmnt = case plmnt of -- this should be tidied up placeSpotUsingLink :: World -> Room -> Placement - -> (RoomPos -> Maybe (PlacementSpot,RoomPos)) + -> (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)) -> (RoomPos -> Room -> Room) -> Maybe Placement -> ((World, Room), [Placement]) @@ -63,14 +63,15 @@ placeSpotUsingLink w rm plmnt extract eff fallback = case searchedPoss (_rmPos r Just plmnt' -> placeSpot (w,rm) plmnt' where searchedPoss [] = Nothing - searchedPoss (pos:poss) = case extract pos of + searchedPoss (pos:poss) = case extract pos rm of Nothing -> second (pos:) <$> searchedPoss poss Just (ps,rmpos) -> Just ( ps,rmpos:poss) -placeSpotRoomRand :: Room -> Int -> Placement -> World -> ((World,Room),[Placement]) -placeSpotRoomRand rm i plmnt w = +placeSpotRoomRand :: Room -> Int -> ((Point2,Float) -> PlacementSpot) + -> Placement -> World -> ((World,Room),[Placement]) +placeSpotRoomRand rm i f plmnt w = let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen w - in placeSpot (w & randGen .~ g,rm) (plmnt & plSpot .~ uncurry PS ps) + in placeSpot (w & randGen .~ g,rm) (plmnt & plSpot .~ f ps) shiftPlacement :: (Point2,Float) -> Placement -> Placement shiftPlacement shift plmnt = case plmnt of diff --git a/src/Dodge/PlacementSpot.hs b/src/Dodge/PlacementSpot.hs index 1edd4f4a1..51679a71c 100644 --- a/src/Dodge/PlacementSpot.hs +++ b/src/Dodge/PlacementSpot.hs @@ -2,29 +2,49 @@ module Dodge.PlacementSpot where import Dodge.LevelGen.Data import Geometry +import Data.Bifunctor import Control.Monad.State import System.Random +setDirPS :: Float -> PlacementSpot -> PlacementSpot +setDirPS a ps = case ps of + PS p _ -> PS p a + PSPos f re fb -> undefined + _ -> error "TODO write this in" + +randDirPS :: RandomGen g => PlacementSpot -> State g PlacementSpot +randDirPS (PSPos f ef fb) = do + a <- state $ randomR (0,pi*2) + return $ PSPos (g a) ef fb + where + g a rp r = fmap (first (setDirPS a)) $ f rp r + +--unusedSpotAwayFromInLinkRD :: RandomGen g => Float -> State g PlacementSpot +--unusedSpotAwayFromInLinkRD x = do +-- a <- state $ randomR (0.2*pi) +-- return PSPos (f a) (const id) Nothing +-- where + -- 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, PosPl p a) - f _ = Nothing + f (UnusedLink p a) _ = Just (PS p a, UsedSpot p a) + 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 _ = Nothing + f (UsedOutLink 0 i p a) _ = Just (PS p a, UsedOutLink 0 i p a) + 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) _ | n == i = Just (PS p' a', UsedOutLink n rmid p a) where (p',a') = theshift (p,a) - f _ = Nothing + f _ _ = Nothing atFstLnkOutShiftBy :: ((Point2,Float) -> (Point2,Float)) -> PlacementSpot atFstLnkOutShiftBy = atNthLnkOutShiftBy 0 @@ -40,22 +60,22 @@ atNthLnkOutShiftInward n x = atNthLnkOutShiftBy n f overFstLnkOut :: PlacementSpot overFstLnkOut = PSPos f (const id) Nothing where - f (UsedOutLink 0 _ p a) = Just (PS p a, PosPl p a) - f _ = Nothing + f (UsedOutLink 0 _ p a) _ = Just (PS p a, UsedSpot p a) + 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' ,PosPl v' a') + f (UnusedLink v a) _ = Just (PS v' a' ,UsedSpot v' a') where v' = v -.- x *.* unitVectorAtAngle (a + 0.5 * pi) a' = a + pi - f _ = Nothing + f _ _ = Nothing -useLnkRoomPos :: RoomPos -> Maybe (PlacementSpot,RoomPos) -useLnkRoomPos rp = case rp of - (UnusedLink (V2 x y) a) -> Just (PS (V2 x y) a , PosPl (V2 x y) a) +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) _ -> Nothing psRandRanges :: (Float,Float) -> (Float,Float) -> (Float,Float) -> State StdGen (Point2,Float) diff --git a/src/Dodge/Room/Link.hs b/src/Dodge/Room/Link.hs index dd1c530d2..84312224f 100644 --- a/src/Dodge/Room/Link.hs +++ b/src/Dodge/Room/Link.hs @@ -16,6 +16,7 @@ module Dodge.Room.Link , changeLinkTo , changeLinkFrom , randomiseOutLinks + , chooseOneInLink ) where import Dodge.Placement.PlaceSpot import Dodge.LevelGen.Data @@ -29,6 +30,17 @@ import Control.Monad.State import Control.Lens import Data.List import qualified Data.Set as S +--import System.Random + +chooseOneInLink :: RandomGen g => Room -> State g Room +chooseOneInLink r = restrictToFstInLink <$> shuffleLinks r + +restrictToFstInLink :: Room -> Room +restrictToFstInLink = rmLinks %~ f + where + f (rl:xs) | S.member InLink (_rlType rl) = rl : restrictLinkType InLink (const False) xs + | otherwise = rl : f xs + f [] = [] {- Shuffle the initial links of a room randomly. -} randomiseOutLinks :: RandomGen g => Room -> State g Room diff --git a/src/Dodge/Room/LongDoor.hs b/src/Dodge/Room/LongDoor.hs index a3a8f6006..93b272c1b 100644 --- a/src/Dodge/Room/LongDoor.hs +++ b/src/Dodge/Room/LongDoor.hs @@ -5,10 +5,12 @@ module Dodge.Room.LongDoor where import Dodge.Data import Dodge.RoomLink import Dodge.Base +import Dodge.Tree import Dodge.Default.Room import Dodge.LevelGen.Data import Dodge.Placement.Instance import Dodge.Room.Link +import Dodge.Room.Door import Dodge.Room.Procedural --import Dodge.Layout.Tree.Either --import Dodge.LevelGen.Data @@ -20,6 +22,8 @@ import Dodge.LightSource import Picture import Geometry +import qualified Data.Set as S +import Data.Tree import System.Random import Control.Lens import Control.Monad.State @@ -106,7 +110,7 @@ addButtonSlowDoor x h rm = do ,( V2 (x/2+50) 5,0::Float) ] thePlacement <- takeOne [butDoor butPos butRot ] - shuffleLinks $ setOutLinks aboveH $ setInLinks belowH (rm + shuffleLinks $ setOutLinksPD aboveH $ setInLinksPD belowH (rm & rmPmnts %~ (thePlacement :) & rmBound %~ (openDoorBound :) ) @@ -116,9 +120,9 @@ 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' , PosPl (V2 x' y') a') - butPosCond _ = Nothing + butPosCond (UnusedLink (V2 x' y') a') _ | y' < 0.5 * h + = Just (PS (V2 x' y') a' , UsedSpot (V2 x' y') a') + butPosCond _ _ = Nothing --butPosCond _ = True -- y < h col = dim $ light red cond' btid w = w ^? buttons . ix btid . btState /= Just BtOff @@ -141,3 +145,12 @@ slowDoorRoom = do proom <- southPillarsRoom x y h addButtonSlowDoor x h (proom & rmPmnts %~ (++ (crits ++ barrels ++ lsources))) +slowDoorRoomRunPast :: RandomGen g => State g (SubCompTree Room) +slowDoorRoomRunPast = do + r <- slowDoorRoom + return $ treeFromTrunk [PassDown door] + (Node (PassDown r) + [ singleUseAll door + , return (UseLabel 0 $ door & rmConnectsTo .~ S.singleton InLink) + ] + ) diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs index 19a765d24..ceea6bb6f 100644 --- a/src/Dodge/Room/Procedural.hs +++ b/src/Dodge/Room/Procedural.hs @@ -47,8 +47,9 @@ roomRect -> Room roomRect x y xn yn = defaultRoom { _rmPolys = [rectNSWE y 0 0 x ] - , _rmLinks = init lnks ++ [last lnks] + , _rmLinks = lnks , _rmPath = concatMap doublePair pth + , _rmPos = map (\p -> UnusedSpot p 0) posps , _rmPmnts = [] , _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)] , _rmFloor = [Tile @@ -66,8 +67,10 @@ 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 = map toBothLnk $ nlnks ++ elnks ++ wlnks ++ slnks + lnks = m North nlnks ++ m East elnks ++ m West wlnks ++ m South slnks + m edge = map (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 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) diff --git a/src/Dodge/Room/RoadBlock.hs b/src/Dodge/Room/RoadBlock.hs index 2c9ebf1da..364ccb0b9 100644 --- a/src/Dodge/Room/RoadBlock.hs +++ b/src/Dodge/Room/RoadBlock.hs @@ -77,8 +77,8 @@ dirtPoly :: [Point2] -> PSType dirtPoly = PutBlock DirtBlock [1] dirtWall . reverse -- | A single corridor with a destructible block blocking it. -blockedCorridor' :: RandomGen g => State g Room -blockedCorridor' = do +blockedCorridorCloseBlocks :: RandomGen g => State g Room +blockedCorridorCloseBlocks = do r <- state $ randomR (0,pi) theblocks <- takeOne [ -- [sPS (V2 20 40) r $ dirtPoly $ square 10] @@ -86,8 +86,10 @@ blockedCorridor' = do -- , sPS (V2 35 40) (r+0.5) $ dirtPoly $ square 10 -- ] --, - [ sPS (V2 5 50) r $ dirtPoly $ square 10 - , sPS (V2 35 35) (r+0.5) $ dirtPoly $ square 10 + --[ sPS (V2 5 50) r $ dirtPoly $ square 10 + --, sPS (V2 35 35) (r+0.5) $ dirtPoly $ square 10 + [ sPS (V2 6 25) r $ dirtPoly $ square 10 + , sPS (V2 35 20) (r+0.5) $ dirtPoly $ square 10 ] ] return $ corridor & rmPmnts .~ theblocks diff --git a/src/Dodge/Room/Room.hs b/src/Dodge/Room/Room.hs index 3989c0aec..4f15b60fa 100644 --- a/src/Dodge/Room/Room.hs +++ b/src/Dodge/Room/Room.hs @@ -53,8 +53,8 @@ roomPadCut ps p = defaultRoom , _rmPath = [(V2 0 0,p)] } roomPillars :: Room -roomPillars = --over rmLinks init $ -- it is unclear to me the purpose of this: perhaps to get the in link in the center? - set rmPmnts plmnts $ roomRect 240 240 2 2 +roomPillars = roomRect 240 240 2 2 + & rmPmnts .~ plmnts where plmnts = spanLightI (V2 120 24) (V2 120 216) : mntLS vShape (V2 12 12) (V3 25 25 70) @@ -106,8 +106,8 @@ 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 , PosPl (V2 x y) a) - con1 _ _ = Nothing + con1 cond (UnusedLink (V2 x y) a) _ | cond y = Just (PS (V2 x y) a , UsedSpot (V2 x y) a) + con1 _ _ _ = Nothing plmnts = [ mntLightLnkCond $ con1 (< 0.5 * hgt) , mntLightLnkCond $ con1 (> 0.5 * hgt) @@ -134,8 +134,8 @@ glassSwitchBack = do glassSwitchBackCrits :: RandomGen g => State g Room glassSwitchBackCrits = glassSwitchBack - <&> rmPmnts %~ ([spNoID (PSRoomRand 0) (PutCrit miniGunCrit) - , spNoID (PSRoomRand 1) randC1 + <&> rmPmnts %~ ([spNoID (PSRoomRand 0 (uncurry PS)) (PutCrit miniGunCrit) + , spNoID (PSRoomRand 1 (uncurry PS)) randC1 ] ++) miniTree2 :: RandomGen g => State g (SubCompTree Room) @@ -182,7 +182,7 @@ rot90Around cen p = cen +.+ vNormal (p -.- cen) -- inside an inner tree roomMiniIntro :: RandomGen g => State g (SubCompTree Room) roomMiniIntro = do - midroom <- join $ takeOne [miniTree2,glassLesson] + midroom <- join $ takeOne [miniTree2] --,glassLesson] return $ chainUses [return $ UseAll door, midroom,return $ UseAll corridor] roomCenterPillar :: RandomGen g => State g Room @@ -328,7 +328,7 @@ weaponLongCorridor :: RandomGen g => State g (SubCompTree Room) weaponLongCorridor = do root <- takeOne [tEast, tWest] connectingRoom <- takeOne - [tEast & rmPmnts .~ [spanLightI (V2 (-40) 40) (V2 (-40) 80)] + [tEast & rmPmnts .~ [spanLightI (V2 (-30) 40) (V2 (-30) 80)] ] i1 <- state $ randomR (2,5) i2 <- state $ randomR (2,5) @@ -356,16 +356,16 @@ deadEndRoom = defaultRoom {- A random Either tree with a weapon and melee monster challenge. -} weaponRoom :: RandomGen g => State g (SubCompTree Room) weaponRoom = join $ takeOne - [ weaponEmptyRoom - , weaponUnderCrits - , weaponBehindPillar - , weaponBetweenPillars - , weaponLongCorridor + [-- weaponEmptyRoom + --, weaponUnderCrits + --, weaponBehindPillar + weaponBetweenPillars + --, weaponLongCorridor ] roomCCrits :: RandomGen g => State g Room roomCCrits = roomC 200 200 - <&> rmPmnts %~ (replicate 20 (spNoID (PSRoomRand 0) randC1) ++ ) + <&> rmPmnts %~ (replicate 20 (spNoID (PSRoomRand 0 (uncurry PS)) randC1) ++ ) longRoom :: RandomGen g => State g Room longRoom = do @@ -432,13 +432,13 @@ shootersRoom' = do shootersRoom1 :: RandomGen g => State g Room shootersRoom1 = shootersRoom' <&> rmPmnts %~ ( ( - RandomPlacement $ takeOne $ map (\i -> spNoID (PSRoomRand i) (PutCrit autoCrit)) + RandomPlacement $ takeOne $ map (\i -> spNoID (PSRoomRand i (uncurry PS)) (PutCrit autoCrit)) [0,1,2] ) :) shootersRoom :: RandomGen g => State g Room shootersRoom = shootersRoom' <&> rmPmnts %~ - ( map (\i -> spNoID (PSRoomRand i) (PutCrit autoCrit)) + ( map (\i -> spNoID (PSRoomRand i (uncurry PS)) (PutCrit autoCrit)) [0,1,2] ++ ) @@ -477,9 +477,9 @@ pillarGrid = do pistolerRoom :: RandomGen g => State g Room pistolerRoom = pillarGrid <&> rmPmnts %~ ( - [spNoID (PSRoomRand 0) (PutCrit pistolCrit) - ,spNoID (PSRoomRand 0) (PutCrit pistolCrit) - ,spNoID (PSRoomRand 0) (PutCrit pistolCrit) + [spNoID (PSRoomRand 0 (uncurry PS)) (PutCrit pistolCrit) + ,spNoID (PSRoomRand 0 (uncurry PS)) (PutCrit pistolCrit) + ,spNoID (PSRoomRand 0 (uncurry PS)) (PutCrit pistolCrit) ] ++) @@ -506,6 +506,6 @@ spawnerRoom = do x <- state $ randomR (250,300) y <- state $ randomR (300,400) roomWithSpawner <- roomC x y <&> - rmPmnts %~ (spNoID (PSRoomRand 0) (PutCrit spawnerCrit) :) + rmPmnts %~ (spNoID (PSRoomRand 0 (uncurry PS)) (PutCrit spawnerCrit) :) aRoom <- airlock return $ treeFromTrunk [PassDown aRoom,PassDown corridor] $ singleUseAll roomWithSpawner diff --git a/src/Dodge/Room/Start.hs b/src/Dodge/Room/Start.hs index dd0dfaf31..df5d7d310 100644 --- a/src/Dodge/Room/Start.hs +++ b/src/Dodge/Room/Start.hs @@ -10,6 +10,7 @@ import Dodge.Default import Dodge.Tree import Dodge.RandomHelp import Dodge.Room.Door +import Dodge.Room.RezBox import Dodge.Room.Corridor import Dodge.Room.Room import Dodge.Room.Link @@ -67,11 +68,11 @@ startRoom :: RandomGen g => Int -> State g (SubCompTree Room) startRoom i = join $ takeOne [-- roomMiniIntro --minigunfakeout - rezBoxesWp - , rezBoxesThenWeaponRoom - , rezBoxThenWeaponRoom - , rezBoxesWpCrit - , runPastStart i +-- rezBoxesWp + rezBoxesThenWeaponRoom +-- , rezBoxThenWeaponRoom +-- rezBoxesWpCrit +-- , runPastStart i ] runPastStart :: RandomGen g => Int -> State g (SubCompTree Room) @@ -85,33 +86,6 @@ rezBoxStart = do ls <- rezColor return $ treeFromPost [PassDown $ rezBox ls] (UseAll door) -rezBox :: LightSource -> Room -rezBox ls = roomRect 40 60 1 1 - & rmPmnts .~ [ sPS (V2 20 1) 0 $ PutLS ls] -rezColor :: RandomGen g => State g LightSource -rezColor = do - col <- takeOne [V3 0.0 0.1 0.5, V3 0.0 0.5 0.1] - h <- takeOne [30,50,80,90,90,90,90] - rad <- takeOne [150,200,200,250,250,300,300,300] - return defaultLS - { _lsPos = V3 0 0 h - , _lsIntensity = col - , _lsRad = rad - } - -rezInvBox :: LightSource -> Room -rezInvBox = swapInOutLinks . rezBox - -crAdd :: Room -> Room -crAdd = rmPmnts %~ (sPS (V2 20 10) (0.5*pi) randC1 :) - -wpAdd :: Item -> Room -> Room -wpAdd wp = rmPmnts %~ f - where - f (x:xs) = sPS (V2 15 30) 1 (PutFlIt wp) : g x : xs - f _ = [sPS (V2 15 30) 1 (PutFlIt wp)] - g x = x & plIDCont .~ flickerMod - rezBoxesThenWeaponRoom :: RandomGen g => State g (SubCompTree Room) rezBoxesThenWeaponRoom = do @@ -124,72 +98,7 @@ rezBoxThenWeaponRoom = do rcol <- rezColor treeFromTrunk [PassDown $ rezBox rcol,PassDown door] <$> weaponRoom -rezBoxesWpCrit :: RandomGen g => State g (SubCompTree Room) -rezBoxesWpCrit = do - w <- state $ randomR (200,400) - h <- state $ randomR (40,40) - thecol <- rezColor - theweapon <- randBlockBreakWeapon - let bottomEdgeTest (V2 _ y,_) = y < 1 - bottomPassDownTest (V2 x y,_) = y < 1 && x < 21 - aroom = rezInvBox thecol - centralRoom <- filterSortOutLinksOn bottomEdgeTest ((\(V2 a b) -> (b,a)) . fst) <$> - (randomiseOutLinks =<< changeLinkTo bottomPassDownTest - ((roomRectAutoLinks w h) {_rmPmnts = []})) - let n = length $ filter bottomEdgeTest $ map lnkPosDir $ _rmLinks centralRoom - i <- state $ randomR (0,n-3) - j <- state $ randomR (i,n-2) - blcor <- blockedCorridor' - let rezrooms = map adddoor - $ insertAt i (wpAdd theweapon aroom) - $ insertAt j (crAdd aroom) - $ replicate (n-3) aroom - return $ treeFromTrunk [PassDown $ rezBox thecol - , PassDown door - ] - (Node (PassDown centralRoom) (rezrooms ++ [onwardtree blcor])) - where - adddoor rm = treeFromPost [PassDown door] (PassDown rm) - onwardtree blcor = treeFromPost [PassDown door] (UseAll blcor) -rezBoxesWp :: RandomGen g => State g (SubCompTree Room) -rezBoxesWp = do - w <- state $ randomR (100,400) - h <- state $ randomR (40,40) - theweapon <- randBlockBreakWeapon - thecol <- rezColor - let bottomEdgeTest (V2 _ y,_) = y < 1 - aroom = rezInvBox thecol - centralRoom <- randomiseOutLinks =<< changeLinkTo bottomEdgeTest - ((roomRectAutoLinks w h) {_rmPmnts = []}) - blcor <- blockedCorridor' - let n = length $ filter bottomEdgeTest $ map lnkPosDir $_rmLinks centralRoom - let rezrooms = map adddoor - $ wpAdd theweapon aroom : replicate (n-2) aroom - centralRoom' <- changeLinkFrom bottomEdgeTest centralRoom - return $ treeFromTrunk [PassDown $ rezBox thecol - , PassDown door - ] - (Node (PassDown centralRoom') (rezrooms ++ [onwardtree blcor])) - where - adddoor rm = treeFromPost [PassDown door] (PassDown rm) - onwardtree blcor = treeFromPost [PassDown door] (UseAll blcor) - -rezBoxes :: RandomGen g => State g (SubCompTree Room) -rezBoxes = do - w <- state $ randomR (100,400) - h <- state $ randomR (40,40) - thecol <- rezColor - let bottomEdgeTest (V2 _ y,_) = y < 1 - dbox = treeFromPost [PassDown door] (PassDown $ rezInvBox thecol) - centralRoom <- randomiseOutLinks =<< changeLinkTo bottomEdgeTest - ((roomRectAutoLinks w h) {_rmPmnts = []}) - let n = length $ filter bottomEdgeTest $ map lnkPosDir $_rmLinks centralRoom - centralRoom' <- changeLinkFrom bottomEdgeTest centralRoom - return $ treeFromTrunk [PassDown $ rezBox thecol - , PassDown door - ] - (Node (PassDown centralRoom') (replicate (n-1) dbox ++ [Node (UseAll door) []])) startRoom' :: RandomGen g => State g (SubCompTree Room) startRoom' = do diff --git a/src/Dodge/RoomLink.hs b/src/Dodge/RoomLink.hs index 00bf01f72..15c173717 100644 --- a/src/Dodge/RoomLink.hs +++ b/src/Dodge/RoomLink.hs @@ -9,8 +9,11 @@ import Control.Lens restrictLinkType :: RoomLinkType -> ((Point2,Float) -> Bool) -> [RoomLink] -> [RoomLink] restrictLinkType rlt f = map g where - g rl | f $ rlPosDir rl = rl & rlType %~ S.delete rlt - | otherwise = rl + g rl | f $ rlPosDir rl = rl + | otherwise = rl & rlType %~ S.delete rlt + +getLinksOfType :: RoomLinkType -> [RoomLink] -> [RoomLink] +getLinksOfType lt = filter (S.member lt . _rlType) restrictInLinks :: ((Point2,Float) -> Bool) -> Room -> Room restrictInLinks f = rmLinks %~ restrictLinkType InLink f @@ -18,17 +21,26 @@ restrictInLinks f = rmLinks %~ restrictLinkType InLink f restrictOutLinks :: ((Point2,Float) -> Bool) -> Room -> Room restrictOutLinks f = rmLinks %~ restrictLinkType OutLink f -setLinkType :: RoomLinkType -> ((Point2,Float) -> Bool) -> [RoomLink] -> [RoomLink] +setInLinks :: (RoomLink -> Bool) -> [RoomLink] -> [RoomLink] +setInLinks = setLinkType InLink + +setLinkType :: RoomLinkType -> (RoomLink -> Bool) -> [RoomLink] -> [RoomLink] setLinkType rlt f = map g where - g rl | f $ rlPosDir rl = rl & rlType %~ S.delete rlt - | otherwise = rl & rlType %~ S.insert rlt -setInLinks :: ((Point2,Float) -> Bool) -> Room -> Room -setInLinks f = rmLinks %~ setLinkType InLink f + g rl | f rl = rl & rlType %~ S.insert rlt + | otherwise = rl & rlType %~ S.delete rlt -setOutLinks :: ((Point2,Float) -> Bool) -> Room -> Room -setOutLinks f = rmLinks %~ setLinkType OutLink f +setLinkTypePD :: RoomLinkType -> ((Point2,Float) -> Bool) -> [RoomLink] -> [RoomLink] +setLinkTypePD rlt f = map g + where + g rl | f $ rlPosDir rl = rl & rlType %~ S.insert rlt + | otherwise = rl & rlType %~ S.delete rlt +setInLinksPD :: ((Point2,Float) -> Bool) -> Room -> Room +setInLinksPD f = rmLinks %~ setLinkTypePD InLink f + +setOutLinksPD :: ((Point2,Float) -> Bool) -> Room -> Room +setOutLinksPD f = rmLinks %~ setLinkTypePD OutLink f swapInOutLinks :: Room -> Room swapInOutLinks = rmLinks %~ map (rlType %~ S.map f) @@ -66,6 +78,12 @@ inLink p a = RoomLink ,_rlPos = p , _rlDir = a } +lnkBothAnd :: RoomLinkType -> (Point2,Float) -> RoomLink +lnkBothAnd rlt (p,a) = RoomLink + {_rlType = S.fromList [OutLink,InLink,rlt] + ,_rlPos = p + , _rlDir = a + } toBothLnk :: (Point2,Float) -> RoomLink toBothLnk (p,a) = RoomLink diff --git a/src/Dodge/Tree/Compose.hs b/src/Dodge/Tree/Compose.hs index cd4cf392c..7699c4b19 100644 --- a/src/Dodge/Tree/Compose.hs +++ b/src/Dodge/Tree/Compose.hs @@ -8,11 +8,13 @@ module Dodge.Tree.Compose , useAllAtEnd , changeToPassDown , overwriteLabel + , applyToCompRoot ) where import Dodge.Tree.Compose.Data import Dodge.Tree.Polymorphic import Dodge.Base import Data.Tree +import Control.Lens expandTree :: CompTree a -> Tree a expandTree (Node root extChildren) = case root of @@ -24,6 +26,9 @@ expandTree (Node root extChildren) = case root of Node (SplitDown x) xs -> Node x $ map expandTree $ zipWith Node xs $ map (:[]) extChildren ++ repeat [] +applyToCompRoot :: (a -> a) -> SubCompTree a -> SubCompTree a +applyToCompRoot f = applyToRoot (unCompose %~ f) + overwriteLabel :: Int -> (a -> ComposingNode a) -> SubCompTree a -> [SubCompTree a] -> SubCompTree a overwriteLabel i f t ts = errorHead ("tried to overwriteLabel " ++ show i) $ updateSingleNode islabel update t diff --git a/src/Dodge/Tree/Shift.hs b/src/Dodge/Tree/Shift.hs index d21dc8153..3b108ee3a 100644 --- a/src/Dodge/Tree/Shift.hs +++ b/src/Dodge/Tree/Shift.hs @@ -12,6 +12,7 @@ import Geometry.ConvexPoly import Geometry.Data import Padding +import qualified Data.Set as S import Data.Tree import Data.Sequence hiding (zipWith) import Data.List (delete) @@ -34,8 +35,12 @@ posRms bounds (parent,_) [] st = case st of Node childi ts :<| tseq -> fmap (parent:) <$> posRms bounds childi (zipCount ts) tseq posRms bounds parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do printInfoCheckNum parenti numChild childi - tryParentLinks $ zipCount $ rmOutLinks parent + tryParentLinks outlinks where + child = fst childi + outlinks = zipCount + . Prelude.filter (not . S.null . S.intersection (_rmConnectsTo child) . _rlType) + $ _rmLinks parent tryParentLinks [] = putStrLn "no viable link pairs, backtrack" >> return Nothing tryParentLinks ((j,outlnk):ls) = tryChildLinks $ zipCount (rmInLinks $ fst childi) where