From 0c580e63a473ba1cb5fa47644053e7e86929438a Mon Sep 17 00:00:00 2001 From: justin Date: Sat, 5 Mar 2022 01:09:19 +0000 Subject: [PATCH] Start cleanup of room in-links --- src/Dodge/Creature/ChaseCrit.hs | 2 +- src/Dodge/Floor.hs | 1 + src/Dodge/LevelGen/Data.hs | 1 - src/Dodge/LockAndKey.hs | 11 +++-- src/Dodge/Placement/Instance/LightSource.hs | 1 - src/Dodge/Placement/PlaceSpot.hs | 18 +++---- src/Dodge/Placement/PlaceSpot/TriggerDoor.hs | 49 +++++++++----------- src/Dodge/Room/Procedural.hs | 20 ++++---- src/Dodge/Room/RezBox.hs | 29 +++--------- src/Dodge/Room/Room.hs | 11 ++--- src/Dodge/Room/Start.hs | 14 +++--- 11 files changed, 67 insertions(+), 90 deletions(-) diff --git a/src/Dodge/Creature/ChaseCrit.hs b/src/Dodge/Creature/ChaseCrit.hs index 747b35583..aa3bf248b 100644 --- a/src/Dodge/Creature/ChaseCrit.hs +++ b/src/Dodge/Creature/ChaseCrit.hs @@ -44,7 +44,7 @@ chaseCrit = defaultCreature , Left targetYouWhenCognizant , Right (crMeleeCooldown %~ max 0 . subtract 1) ] - , _crHP = 300 + , _crHP = 150 , _crPict = basicCrPict green , _crInv = IM.fromList [(0,medkit 200)] , _crMeleeCooldown = 0 diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 5b8f20570..5551e80ae 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -34,6 +34,7 @@ import System.Random initialAnoTree :: RandomGen g => Tree [Annotation g] initialAnoTree = padSucWithCorridors $ treeFromTrunk [[AnoApplyInt 0 startRoom] + , [SpecificRoom $ fmap (return . UseAll) doubleCorridorBarrels] , [PassthroughLockKeyLists 2 lockRoomKeyItems itemRooms] , [AnoApplyInt 1 lasSensorTurretTest] -- ,[ChainAnos diff --git a/src/Dodge/LevelGen/Data.hs b/src/Dodge/LevelGen/Data.hs index c5ad54baa..24360495e 100644 --- a/src/Dodge/LevelGen/Data.hs +++ b/src/Dodge/LevelGen/Data.hs @@ -206,7 +206,6 @@ psj ps pst plmnt = Placement ps pst Nothing (const $ Just plmnt) ps0jPushPS :: PSType -> Placement -> Placement ps0jPushPS pst plmnt = Placement (PS (V2 0 0) 0) pst Nothing (\p -> Just $ plmnt & plSpot .~ _plSpot p) ---ps0jPushPS pst plmnt = Placement (PS (V2 0 0) 0) pst Nothing (\p -> Just $ plmnt) addPlmnt :: Placement -> Placement -> Placement addPlmnt pl pl2 = case pl2 of diff --git a/src/Dodge/LockAndKey.hs b/src/Dodge/LockAndKey.hs index bfac4713b..e378325ec 100644 --- a/src/Dodge/LockAndKey.hs +++ b/src/Dodge/LockAndKey.hs @@ -11,13 +11,11 @@ import Dodge.Item.Craftable import System.Random import Control.Monad.State --- (const $ return $ chainUses $ map singleUseAll [door,lasTunnel,door] , return FlatShield ) --- , - lockRoomKeyItems :: RandomGen g => [ (Int -> State g (SubCompTree Room) , State g CombineType ) ] lockRoomKeyItems = - [(lasCenSensEdge, takeOne [LAUNCHER,LASGUN,SPARKGUN] ) + [(lasCenSensEdge, takeOne [LAUNCHER,LASGUN,SPARKGUN,FLATSHIELD] ) ,(const slowDoorRoomRunPast, return MINIGUN) +-- ,(longRoom or something, [sniper]) ] itemRooms :: RandomGen g => [(CombineType, State g (SubCompTree Room))] @@ -36,6 +34,11 @@ itemRooms = [roomsContaining $ map makeTypeCraft [TRANSFORMER,CAN,CAN] ] ) + , (FLATSHIELD , join $ takeOne + [roomsContaining $ map makeTypeCraft [PLATE,PLATE] + ,roomsContaining $ map makeTypeCraft [DRUM,DRUM,PLATE] + ] + ) ] roomsContaining :: RandomGen g => [Item] -> State g (SubCompTree Room) diff --git a/src/Dodge/Placement/Instance/LightSource.hs b/src/Dodge/Placement/Instance/LightSource.hs index d04a1f7d8..865ffb6c5 100644 --- a/src/Dodge/Placement/Instance/LightSource.hs +++ b/src/Dodge/Placement/Instance/LightSource.hs @@ -28,7 +28,6 @@ mntLSOn shapeF mcol ls wallp lsp@(V3 lx ly _) V2 x y = rotateV 1 . (0.1 *.*) . normalizeV $ wallp -.- V2 lx ly setCol = maybe id colorSH mcol - iShape :: Point2 -> Point3 -> Shape iShape wp (V3 x y z) = thinHighBar z wp (V2 x y) diff --git a/src/Dodge/Placement/PlaceSpot.hs b/src/Dodge/Placement/PlaceSpot.hs index 46fba121c..6676b4203 100644 --- a/src/Dodge/Placement/PlaceSpot.hs +++ b/src/Dodge/Placement/PlaceSpot.hs @@ -87,20 +87,20 @@ placeSpotRoomRand rm i f plmnt w = -- the Int here is some id that is assigned when the placement is placed placeSpotID :: PlacementSpot -> PSType -> GenWorld -> (Int, GenWorld) placeSpotID ps pt w = case pt of - PutTrigger cnd -> placeNewInto triggers cnd w + PutTrigger cnd -> plNewID triggers cnd w PutMod mdi -> plNewUpID modifications mdID mdi w PutProp prp -> plNewUpID props pjID (mvProp p rot prp) w PutButton bt -> plNewUpID buttons btID (mvButton p rot bt) w PutFlIt itm -> plNewUpID floorItems flItID (createFlIt p rot itm) w PutCrit cr -> plNewUpID creatures crID (mvCr p rot cr) w - PutMachine col pps mc -> placeMachine col (map doShift pps) mc p rot w + PutMachine col pps mc -> plMachine col (map doShift pps) mc p rot w PutLS ls -> plNewUpID lightSources lsID (mvLS p' rot ls) w PutPPlate pp -> plNewUpID pressPlates ppID (mvPP p rot pp) w RandPS rgn -> evaluateRandPS rgn ps w - PutDoor col f pss -> placeDoor col f (map (bimap doShift doShift) pss) w - PutCoord cp -> placeNewInto coordinates (doShift cp) w + PutDoor col f pss -> plDoor col f (map (bimap doShift doShift) pss) w + PutCoord cp -> plNewID coordinates (doShift cp) w PutSlideDr pth col f a b spd - -> placeSlideDoor pth col f (doShift a) (doShift b) spd w + -> plSlideDoor pth col f (doShift a) (doShift b) spd w PutBlock bm hp hps wl ps' -> placeBlock (map doShift ps') hp wl hps bm w PutLineBlock wl bm wdth dpth a b -> placeLineBlock wl bm wdth dpth (doShift a) (doShift b) w @@ -142,11 +142,11 @@ addPane wl l wls = IM.insert wlid (wl { _wlLine = l, _wlID = wlid }) wls -- | generalised way of putting a new item into a lensed intmap, returning the -- new index as well -placeNewInto :: ALens' World (IM.IntMap a) +plNewID :: ALens' World (IM.IntMap a) -> a -> GenWorld -> (Int,GenWorld) -placeNewInto l x w = (i,w & gWorld . l #%~ IM.insert i x) +plNewID l x w = (i,w & gWorld . l #%~ IM.insert i x) where i = IM.newKey $ _gWorld w ^# l @@ -176,8 +176,8 @@ mvPP p rot pp = pp {_ppPos = p,_ppRot = rot} mvCr :: Point2 -> Float -> Creature -> Creature mvCr p rot cr = cr {_crPos = p,_crOldPos = p,_crDir = rot} -placeMachine :: Color -> [Point2] -> Machine -> Point2 -> Float -> GenWorld -> (Int,GenWorld) -placeMachine color wallpoly mc p rot gw = (mcid +plMachine :: Color -> [Point2] -> Machine -> Point2 -> Float -> GenWorld -> (Int,GenWorld) +plMachine color wallpoly mc p rot gw = (mcid , gw & gWorld . machines %~ addMc & gWorld . walls %~ placeMachineWalls color wallpoly mcid wlid ) diff --git a/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs b/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs index 1fdf96f3d..903f3a567 100644 --- a/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs +++ b/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs @@ -1,7 +1,7 @@ --{-# LANGUAGE BangPatterns #-} module Dodge.Placement.PlaceSpot.TriggerDoor - ( placeDoor - , placeSlideDoor + ( plDoor + , plSlideDoor ) where import Dodge.Data import Dodge.Default.Wall @@ -17,14 +17,13 @@ import Data.List import Control.Lens --import Data.Graph.Inductive hiding ((&)) import qualified Data.IntSet as IS -placeDoor - :: Color +plDoor :: Color -> (World -> Bool) -- ^ Opening condition -> [(Point2,Point2)] -- ^ Door positions, closed to open. -- Bumped out up and down by 9, not widened -> GenWorld -> (Int,GenWorld) -placeDoor col cond pss gw = (drid, gw & gWorld .~ (addWalls w & doors %~ addDoor)) +plDoor col cond pss gw = (drid, gw & gWorld .~ (addWalls w & doors %~ addDoor)) where w = _gWorld gw drid = IM.newKey $ _doors w @@ -38,27 +37,29 @@ placeDoor col cond pss gw = (drid, gw & gWorld .~ (addWalls w & doors %~ addDoo nsteps = length pss - 1 wlids = take 4 [IM.newKey $ _walls w ..] wlps' = uncurry (rectanglePairs 9) $ head pss - addWalls w' = foldl' addWall w' $ zip wlids wlps' - addWall w' (wlid, wlps) = w' & walls %~ IM.insert wlid defaultWall - { _wlLine = wlps - , _wlID = wlid - , _wlColor = col - , _wlSeen = False - , _wlOpacity = Opaque - , _wlPathable = False - } + addWalls w' = foldl' (addDoorWall col False) w' $ zip wlids wlps' + +addDoorWall :: Color -> Bool -> World -> (Int,(Point2,Point2)) -> World +addDoorWall col pathableStatus w (wlid,wlps) = w & walls %~ IM.insert wlid defaultWall + { _wlLine = wlps + , _wlID = wlid + , _wlColor = col + , _wlSeen = False + , _wlOpacity = Opaque + , _wlPathable = pathableStatus + } -- TODO use vector instead of list, perhaps also memoisation of rectanglePairs -- perhaps also remove use of DoorInt in favour of DoorOpen/DoorClosed doorMechanismStepwise :: Int -> Int -> [Int] -> [(Point2,Point2)] -> Door -> World -> World doorMechanismStepwise nsteps drid wlids pss dr w | toOpen = case _drStatus dr of DoorInt x | x == nsteps -> w - DoorInt x -> setWalls (x+1) - _ -> w + DoorInt x -> setWalls (x+1) + _ -> w | otherwise = case _drStatus dr of DoorInt 0 -> w DoorInt x -> setWalls (x-1) - _ -> w + _ -> w where playSound = soundContinue (WallSound drid) (fst $ head pss) slideDoorS (Just 1) toOpen = _drTrigger dr w @@ -88,9 +89,9 @@ doorMechanism drid speed wlidOpCps dr w doClose w' (wlid,_ ,clp) = moveWallIDToward wlid speed clp w' -- TODO cut pathing if not pathable, reset when opened -placeSlideDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> GenWorld +plSlideDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> GenWorld -> (Int, GenWorld) -placeSlideDoor isPathable col cond a b speed gw = (drid, gw & gWorld .~ (addWalls w & doors %~ addDoor)) +plSlideDoor isPathable col cond a b speed gw = (drid, gw & gWorld .~ (addWalls w & doors %~ addDoor)) where w = _gWorld gw drid = IM.newKey $ _doors w @@ -101,15 +102,7 @@ placeSlideDoor isPathable col cond a b speed gw = (drid, gw & gWorld .~ (addWall , _drTrigger = cond , _drMech = doorMechanism drid speed (zip3 wlids shiftedPairs pairs) } - addWalls w' = foldl' addWall w' $ zip wlids pairs - addWall w' (wlid, wlps) = w' & walls %~ IM.insert wlid defaultWall - { _wlLine = wlps - , _wlID = wlid - , _wlColor = col - , _wlSeen = False - , _wlOpacity = Opaque - , _wlPathable = isPathable - } + addWalls w' = foldl' (addDoorWall col isPathable) w' $ zip wlids pairs pairs = rectanglePairs 9 a b shiftedPairs = map (bimap shiftLeft shiftLeft) pairs shiftLeft = (+.+ (a -.- b +.+ normalizeV (b -.- a))) diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs index 0c280ea94..89ad720b5 100644 --- a/src/Dodge/Room/Procedural.hs +++ b/src/Dodge/Room/Procedural.hs @@ -90,8 +90,7 @@ combineRooms r r' = defaultRoom , _rmLinks = _rmLinks r ++ _rmLinks r' , _rmPath = map clampPath $ _rmPath r ++ _rmPath r' - , _rmPmnts = (_rmPmnts r) - ++ (_rmPmnts r') + , _rmPmnts = _rmPmnts r ++ _rmPmnts r' --, _rmPmnts = map (shiftPlacement $ _rmShift r) (_rmPmnts r) -- ++ map (shiftPlacement $ _rmShift r') (_rmPmnts r') , _rmBound = _rmBound r ++ _rmBound r' @@ -142,22 +141,21 @@ quarterRoomTri w = do } quarterRoomSquare :: RandomGen g => Float -> State g Room quarterRoomSquare w = do + let commonPlacements = + [ blockLine (V2 (w/2) (w/2)) (V2 0 w) + , sPS (V2 20 (2*w-40)) pi PutNothing + , sPS (V2 25 (2*w-45)) pi PutNothing + ] b <- takeOne [ [ mntLS vShape (V2 0 (2*w-20)) (V3 0 (2*w-40) 70) - , blockLine (V2 (w/2) (w/2)) (V2 0 w) , blockLine (V2 (negate $ w/2) (w/2)) (V2 0 w) - , sPS (V2 20 (2*w-40)) pi PutNothing - ] + ] ++ commonPlacements , [ mntLS vShape (V2 0 (2*w-20)) (V3 0 (2*w-40) 70) - , blockLine (V2 (w/2) (w/2)) (V2 0 w) , blockLine (V2 (negate w) w ) (V2 0 w) - , sPS (V2 20 (2*w-40)) pi PutNothing - ] + ] ++ commonPlacements , [ mntLS iShape (V2 (0.7*w) (1.3*w)) (V3 (0.7*w-20) (1.3*w-20) 70) - , blockLine (V2 (w/2) (w/2)) (V2 0 w) , blockLine (V2 0 w) (V2 0 (w*2)) - , sPS (V2 20 (2*w-40)) pi PutNothing - ] + ] ++ commonPlacements ] pure $ defaultRoom { _rmPolys = [ map toV2 [(0,0),(w,w),(0,2*w),(-w,w)] ] diff --git a/src/Dodge/Room/RezBox.hs b/src/Dodge/Room/RezBox.hs index b4b1fb279..2a3bc1e78 100644 --- a/src/Dodge/Room/RezBox.hs +++ b/src/Dodge/Room/RezBox.hs @@ -70,45 +70,28 @@ rezBoxesWpCrit = do h <- state $ randomR (40,40) thecol <- rezColor theweapon <- randBlockBreakWeapon - --horedge <- takeOne [OnEdge North,OnEdge South] - let centralRoom = (roomRectAutoLinks w h) {_rmPmnts = []} - onwardpassage <- - applyToCompRoot (rmConnectsTo .~ S.singleton (OnEdge West)) <$> maybeBlockedPassage let bottomEdgeTest (V2 _ y,_) = y < 1 aroom = rezInvBox thecol + let centralRoom = (roomRectAutoLinks w h) {_rmPmnts = []} + onwardpassage <- + applyToCompRoot (rmConnectsTo .~ S.singleton (OnEdge West)) <$> maybeBlockedPassage let n = length $ filter bottomEdgeTest $ map lnkPosDir $ _rmLinks centralRoom i <- state $ randomR (0,n-3) j <- state $ randomR (i,n-2) - let rezrooms = map adddoor + 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 ++ [onwardpassage])) where - adddoor rm = treeFromPost [PassDown door] (PassDown rm) + adddoor rm = treeFromPost [PassDown $ door & rmConnectsTo .~ S.singleton (OnEdge North)] (PassDown rm) crAdd :: Room -> Room crAdd = rmPmnts %~ (sPS (V2 20 10) (0.5*pi) randC1 :) -corridorLRbranches :: RandomGen g => State g (SubCompTree Room) -corridorLRbranches = 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) []])) - rezBoxes :: RandomGen g => State g (SubCompTree Room) rezBoxes = do w <- state $ randomR (100,400) diff --git a/src/Dodge/Room/Room.hs b/src/Dodge/Room/Room.hs index d0f6faadc..66fc25b3e 100644 --- a/src/Dodge/Room/Room.hs +++ b/src/Dodge/Room/Room.hs @@ -142,9 +142,8 @@ glassSwitchBackCrits = glassSwitchBack ] ++) miniTree2 :: RandomGen g => State g (SubCompTree Room) -miniTree2 = glassSwitchBackCrits - >>= randomiseOutLinks - >>= changeLinkTo (\p -> (sndV2 . fst) p < 70) +miniTree2 = restrictInLinks (\p -> (sndV2 . fst) p < 70) <$> glassSwitchBackCrits + >>= randomiseAllLinks <&> flip branchWith (replicate 3 $ treeFromPost [door,corridor] critInDeadEnd) miniRoom3 :: RandomGen g => State g (SubCompTree Room) @@ -189,7 +188,7 @@ roomMiniIntro = do return $ chainUses [return $ UseAll door, midroom,return $ UseAll corridor] roomCenterPillar :: RandomGen g => State g Room -roomCenterPillar = changeLinkTo ((\p -> dist p (V2 120 0) < 10) . fst) +roomCenterPillar = randomiseAllLinks . restrictInLinks ((\p -> dist p (V2 120 0) < 10) . fst) $ set rmPmnts plmnts $ roomRect 240 240 2 2 where plmnts = @@ -385,7 +384,7 @@ longRoom = do brls <- fmap (map (\p -> sPS (p +.+ V2 10 200) 0 $ PutCrit explosiveBarrel) ) $ replicateM 5 $ randInRect (w-20) 900 let rm = roomRect w (h+70) 1 1 & rmPolys %~ ([rectNSWE h (h-165) (-45) (w+45)] ++) - changeLinkTo cond $ rm & rmPmnts .~ ws ++ brls ++ wsDefense ++ + return $ restrictInLinks cond $ rm & rmPmnts .~ ws ++ brls ++ wsDefense ++ [sPS (V2 12.5 (h-25)) 0 $ PutCrit longCrit ,sPS (V2 37.5 (h-25)) 0 $ PutCrit longCrit ,sPS (V2 62.5 (h-25)) 0 $ PutCrit longCrit @@ -397,7 +396,7 @@ doubleCorridorBarrels :: RandomGen g => State g Room doubleCorridorBarrels = do h <- state $ randomR (200,300) let cond x = (sndV2 . fst) x < h - 40 - changeLinkTo cond $ roomRect 100 h 1 1 & rmPmnts .~ + return $ restrictInLinks cond $ roomRect 100 h 1 1 & rmPmnts .~ [blockLine (V2 50 50) (V2 50 h) ,sPS (V2 25 (h-25)) 0 $ PutCrit $ addArmour autoCrit ,sPS (V2 75 (h-30)) 0 $ PutCrit explosiveBarrel diff --git a/src/Dodge/Room/Start.hs b/src/Dodge/Room/Start.hs index f2a60c41a..336ec8e29 100644 --- a/src/Dodge/Room/Start.hs +++ b/src/Dodge/Room/Start.hs @@ -65,14 +65,16 @@ room2 :: RandomGen g => Int -> State g (SubCompTree Room) room2 = lasCenSensEdge startRoom :: RandomGen g => Int -> State g (SubCompTree Room) -startRoom _ = join $ uncurry takeOneWeighted $ unzip +startRoom i = join $ uncurry takeOneWeighted $ unzip -- [ (,) (0.5::Float) $ chainUses <$> sequence [minigunFakeout,weaponRoom] - [ (,) (1::Float) rezBoxesWp --- , (,) 1 rezBoxesThenWeaponRoom --- , (,) 1 rezBoxThenWeaponRoom --- , (,) 1 rezBoxesWpCrit --- , (,) 1 $ runPastStart i + [ (,) one rezBoxesWp + , (,) 1 rezBoxesThenWeaponRoom + , (,) 1 rezBoxThenWeaponRoom + , (,) one rezBoxesWpCrit + , (,) 1 $ runPastStart i ] + where + one = (1::Float) runPastStart :: RandomGen g => Int -> State g (SubCompTree Room) runPastStart i = do