justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Work towards cross-room placements

Browse Source
This commit is contained in:
justin
2021-11-12 11:13:59 +00:00
parent d63c2ac943
commit 1d5b2ea765
20 changed files with 147 additions and 165 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Default/Room.hs
+4 -1
View File
@@ -3,13 +3,16 @@ module Dodge.Default.Room
import Geometry.Data import Geometry.Data
import Dodge.Room.Data import Dodge.Room.Data
import qualified Data.IntMap.Strict as IM
defaultRoom :: Room defaultRoom :: Room
defaultRoom = Room defaultRoom = Room
{ _rmPolys = [] { _rmPolys = []
, _rmLinks = [] , _rmLinks = []
, _rmUsedLinks = [] , _rmUsedLinks = []
, _rmPath = [] , _rmPath = []
, _rmPS = [] , _rmPmnts = []
, _rmPartialPmnts = IM.empty
, _rmLabelledPmnts = IM.empty
, _rmBound = [] , _rmBound = []
, _rmFloor = [] , _rmFloor = []
, _rmName = "defaultRoom" , _rmName = "defaultRoom"
src/Dodge/Floor.hs
+8 -10
View File
@@ -15,6 +15,7 @@ import Dodge.Room.Branch
import Dodge.Room.Boss import Dodge.Room.Boss
import Dodge.Room.LongDoor import Dodge.Room.LongDoor
import Dodge.Room.NoNeedWeapon import Dodge.Room.NoNeedWeapon
import Dodge.Room.Link
import Dodge.Layout.Tree.Polymorphic import Dodge.Layout.Tree.Polymorphic
import Dodge.Layout.Tree.Either import Dodge.Layout.Tree.Either
import Dodge.Layout.Tree.Annotate import Dodge.Layout.Tree.Annotate
@@ -31,16 +32,13 @@ import Control.Monad.Loops
import System.Random import System.Random
import Data.Sequence hiding (zipWith) import Data.Sequence hiding (zipWith)
import Data.Maybe import Data.Maybe
initialAnoTree :: RandomGen g => Tree [Annotation g] initialAnoTree :: RandomGen g => Tree [Annotation g]
initialAnoTree = initialAnoTree =
let struct = treeFromPost [[Corridor,SpecificRoom $ fmap (pure . Right) randomFourCornerRoom]] [EndRoom] let struct = treeFromPost [[Corridor,SpecificRoom $ fmap (pure . Right) randomFourCornerRoom]] [EndRoom]
t' = padWithCorridors struct t' = padWithCorridors struct
in treeFromTrunk in treeFromTrunk
[[StartRoom] [[StartRoom]
,[SpecificRoom spawnerRoom]
,[Corridor]
,[Corridor]
,[Corridor]
,[Corridor] ,[Corridor]
,[SpecificRoom $ return $ connectRoom lasTunnel ] ,[SpecificRoom $ return $ connectRoom lasTunnel ]
,[Corridor] ,[Corridor]
@@ -122,12 +120,12 @@ layoutLevelFromSeed i seed = do
putStr $ "Level generation with seed " ++ show seed ++ " failed: " putStr $ "Level generation with seed " ++ show seed ++ " failed: "
let (seed',_) = random g let (seed',_) = random g
layoutLevelFromSeed i' seed' layoutLevelFromSeed i' seed'
where -- where
setLastLinkToUsed rm = case _rmLinks rm of -- setLastLinkToUsed rm = case _rmLinks rm of
(_:_) -> rm -- (_:_) -> rm
& rmLinks %~ init -- & rmLinks %~ init
& rmUsedLinks %~ (last (_rmLinks rm) :) -- & rmUsedLinks %~ (last (_rmLinks rm) :)
_ -> rm -- _ -> rm
compactDrawTree :: Tree String -> String compactDrawTree :: Tree String -> String
compactDrawTree = unlines . compactDraw compactDrawTree = unlines . compactDraw
src/Dodge/Layout.hs
+9 -3
View File
@@ -55,7 +55,7 @@ generateLevelFromRoomList gr w
zs = map fromIntegral $ randomRs (0,63::Int) $ _randGen w zs = map fromIntegral $ randomRs (0,63::Int) $ _randGen w
doRoomPlacements :: World -> Room -> World doRoomPlacements :: World -> Room -> World
doRoomPlacements w rm = fst $ foldl' placeSpot (w,rm) $ _rmPS rm doRoomPlacements w rm = fst $ foldl' placeSpot (w,rm) $ _rmPmnts rm
updatePSLnkUsing :: (Point2,Float) -> PlacementSpot -> PlacementSpot updatePSLnkUsing :: (Point2,Float) -> PlacementSpot -> PlacementSpot
updatePSLnkUsing pf PSLnk{_psLinkShift=f} = uncurry PS $ f pf updatePSLnkUsing pf PSLnk{_psLinkShift=f} = uncurry PS $ f pf
@@ -117,13 +117,19 @@ gameRoomsFromRooms = map f
f rm = GameRoom f rm = GameRoom
{ _grViewpoints = _rmViewpoints rm ++ (map fst . foldl' (flip cutWalls) [] $ _rmPolys rm) { _grViewpoints = _rmViewpoints rm ++ (map fst . foldl' (flip cutWalls) [] $ _rmPolys rm)
++ map fst (_rmLinks rm) ++ map fst (_rmLinks rm)
, _grViewpointsEx = map fst (_rmUsedLinks rm) , _grViewpointsEx = mapMaybe unpos (_rmUsedLinks rm)
, _grBound = expandPolyByFixed 100 . convexHullSafe . nubBy closePoints , _grBound = expandPolyByFixed 100 . convexHullSafe . nubBy closePoints
. concat $ _rmBound rm ++ _rmPolys rm . concat $ _rmBound rm ++ _rmPolys rm
, _grDir = snd . head $ _rmUsedLinks rm , _grDir = getDir $ _rmUsedLinks rm
, _grName = _rmName rm , _grName = _rmName rm
} }
closePoints x y = roundPoint2 x == roundPoint2 y closePoints x y = roundPoint2 x == roundPoint2 y
unpos (OutLink _ p _) = Just p
unpos (InLink p _) = Just p
unpos _ = Nothing
getDir (InLink _ a:_) = a
getDir (_:xs) = getDir xs
getDir _ = 0 -- fallback
floorsFromRooms :: [Room] -> [(Point3,Point3)] floorsFromRooms :: [Room] -> [(Point3,Point3)]
floorsFromRooms = concatMap (concatMap tToRender . _rmFloor) floorsFromRooms = concatMap (concatMap tToRender . _rmFloor)
src/Dodge/Layout/Tree/Annotate.hs
+13 -13
View File
@@ -61,26 +61,26 @@ roomThenCorridor theRoom = fmap (\r -> Node (Left theRoom) [(pure . Right) r])
(randomiseOutLinks corridor) (randomiseOutLinks corridor)
{- | Create a random room tree structure from a list of annotations. -} {- | Create a random room tree structure from a list of annotations. -}
annoToRoomTree :: RandomGen g => [Annotation g] -> State g (Tree (Either Room Room)) annoToRoomTree :: RandomGen g => [Annotation g] -> State g (Tree (Either Room Room))
annoToRoomTree [OrAno as] = do annoToRoomTree anos = case anos of
[OrAno as] -> do
a <- takeOne as a <- takeOne as
annoToRoomTree a annoToRoomTree a
annoToRoomTree [Corridor] = pure . Right <$> randomiseOutLinks corridor [Corridor] -> pure . Right <$> randomiseOutLinks corridor
annoToRoomTree [CorridorDebug] = pure . Right <$> randomiseOutLinks corridorDebug [CorridorDebug] -> pure . Right <$> randomiseOutLinks corridorDebug
annoToRoomTree [DoorAno] = roomThenCorridor door [DoorAno] -> roomThenCorridor door
annoToRoomTree [AirlockAno] = airlock >>= roomThenCorridor [AirlockAno] -> airlock >>= roomThenCorridor
annoToRoomTree [FirstWeapon] = do [FirstWeapon] -> do
branchWP <- branchRectWith weaponRoom branchWP <- branchRectWith weaponRoom
blockedC <- longBlockedCorridor blockedC <- longBlockedCorridor
join $ takeOne $ return (appendEitherTree branchWP [blockedC]) : replicate 5 weaponRoom join $ takeOne $ return (appendEitherTree branchWP [blockedC]) : replicate 5 weaponRoom
annoToRoomTree [EndRoom] = fmap (pure . Right) (telRoomLev 1) [EndRoom] -> fmap (pure . Right) (telRoomLev 1)
annoToRoomTree [StartRoom] = startRoom [StartRoom] -> startRoom
annoToRoomTree (SpecificRoom rt:_) = rt (SpecificRoom rt:_) -> rt
annoToRoomTree (BossAno cr : _) = do (BossAno cr : _) -> do
br <- bossRoom cr br <- bossRoom cr
branchRectWith . pure . fmap Left $ treeFromPost [corridor,corridor] br branchRectWith . pure . fmap Left $ treeFromPost [corridor,corridor] br
annoToRoomTree (TreasureAno crs loot : _) = (TreasureAno crs loot : _) -> branchRectWith . fmap (pure . Left) $ lootRoom crs loot
branchRectWith . fmap (pure . Left) $ lootRoom crs loot _ -> do
annoToRoomTree _ = do
w <- state $ randomR (100,400) w <- state $ randomR (100,400)
h <- state $ randomR (200,400) h <- state $ randomR (200,400)
fmap (pure . Right) . randomiseOutLinks $ roomRectAutoLinks w h fmap (pure . Right) . randomiseOutLinks $ roomRectAutoLinks w h
src/Dodge/Layout/Tree/Shift.hs
+9 -45
View File
@@ -1,11 +1,8 @@
{- | {- | Given a tree of rooms, tries to shift them into place in such a way that their
Given a tree of rooms, tries to shift them into place in such a way that their
links connect and that none of them clip. links connect and that none of them clip.
Returns a list; after this step the structure is determined by the actual positions of rooms. Creates a list of rooms; after this step the structure is determined by the actual positions of rooms. -}
-}
module Dodge.Layout.Tree.Shift module Dodge.Layout.Tree.Shift
( shiftRoomTreeSearchAll ( positionRooms
, positionRooms
) where ) where
import Dodge.Room.Data import Dodge.Room.Data
import Dodge.Room.Link import Dodge.Room.Link
@@ -15,34 +12,9 @@ import Geometry.ConvexPoly
import Data.Tree import Data.Tree
import Data.Sequence hiding (zipWith) import Data.Sequence hiding (zipWith)
import Data.List (delete) import Data.List (delete)
--import Data.Maybe (listToMaybe)
import Data.Bifunctor import Data.Bifunctor
import Control.Lens hiding (Empty, (<|) , (|>)) import Control.Lens hiding (Empty, (<|) , (|>))
{- | All: Depth first search of trees of rooms, produces a list of lists of rooms that are not clipping. -}
shiftRoomTreeSearchAll
:: [ConvexPoly] -- ^ Clipping bounds
-> Seq (Tree Room) -- ^ Rooms to be added
-> [[Room]]
shiftRoomTreeSearchAll _ Empty = [[]]
shiftRoomTreeSearchAll bs (Node r ts :<| tseq)
-- | roomIsClipping = [] -- this is called too often--might get memoized?
-- | otherwise = case ts of
-- [] -> (r :) <$> shiftRoomTreeSearchAll newBounds tseq
-- (s:ss) -> concatMap (\l -> shiftRoomTreeSearchAll bs (Node (useLink l) ss <| (tseq |> f l s))) ls
= case ts of
[] | roomIsClipping -> []
[] -> (r :) <$> shiftRoomTreeSearchAll newBounds tseq
(s:ss) -> concatMap (\l -> shiftRoomTreeSearchAll bs (Node (useLink l) ss <| (tseq |> f l s))) ls
where
convexBounds = map pointsToPoly $ _rmBound r
ls = init $ _rmLinks r
newBounds = convexBounds ++ bs
roomIsClipping = or (convexPolysOverlap <$> convexBounds <*> bs)
useLink l = r & rmLinks %~ delete l
& rmUsedLinks %~ (l :)
f l = applyToRoot (shiftRoomToLink l)
positionRooms :: Tree RoomInt -> IO (Maybe [Room]) positionRooms :: Tree RoomInt -> IO (Maybe [Room])
positionRooms (Node (r,i) ts) = posRms (map pointsToPoly $ _rmBound r) (r,i) ts Empty positionRooms (Node (r,i) ts) = posRms (map pointsToPoly $ _rmBound r) (r,i) ts Empty
@@ -59,30 +31,22 @@ posRms bounds (rtoadd,_) [] (Node (r,i) ts :<| tseq)
= fmap (setLastLinkToUsed rtoadd:) <$> posRms bounds (r,i) ts tseq = fmap (setLastLinkToUsed rtoadd:) <$> posRms bounds (r,i) ts tseq
posRms bounds (r,i) (t@(Node (_,i') _):ts) tseq = do posRms bounds (r,i) (t@(Node (_,i') _):ts) tseq = do
putStr $ "Trying to place room " ++ show i' ++ ": " putStr $ "Trying to place room " ++ show i' ++ ": "
tryLinks' (0::Int) (_rmLinks r) tryLinks (0::Int) (_rmLinks r)
where where
tryLinks' _ [] = do tryLinks _ [] = do
putStrLn "all links tried" putStrLn "all links tried"
return Nothing return Nothing
tryLinks' j (l:ls) tryLinks j (l:ls)
| clipping = tryLinks' (j+1) ls | clipping = tryLinks (j+1) ls
| otherwise = do | otherwise = do
putStrLn $ "placing at link " ++ show j putStrLn $ "placing at link " ++ show j
mayrs <- posRms (convexBounds ++ bounds) useLink ts (tseq |> shiftedt) mayrs <- posRms (convexBounds ++ bounds) useLink ts (tseq |> shiftedt)
case mayrs of case mayrs of
Nothing -> do putStr ("Backtracking to room " ++ show i' ++ ": ") >> tryLinks' (j+1) ls Nothing -> do putStr ("Backtracking to room " ++ show i' ++ ": ") >> tryLinks (j+1) ls
Just rs -> return (Just rs) Just rs -> return (Just rs)
where where
convexBounds = map pointsToPoly $ _rmBound r' convexBounds = map pointsToPoly $ _rmBound r'
clipping = or (convexPolysOverlap <$> convexBounds <*> bounds) clipping = or (convexPolysOverlap <$> convexBounds <*> bounds)
useLink = (r & rmLinks %~ delete l & rmUsedLinks %~ (l :) useLink = (r & rmLinks %~ delete l & rmUsedLinks %~ (uncurry (OutLink (Prelude.length ts)) l :)
, i) , i)
shiftedt@(Node (r',_) _) = applyToRoot (first $ shiftRoomToLink l) t shiftedt@(Node (r',_) _) = applyToRoot (first $ shiftRoomToLink l) t
setLastLinkToUsed :: Room -> Room
setLastLinkToUsed rm = case _rmLinks rm of
(_:_) -> rm
& rmLinks %~ init
& rmUsedLinks %~ (last (_rmLinks rm) :)
_ -> rm
src/Dodge/Placements/Wall.hs
+1 -1
View File
@@ -89,7 +89,7 @@ replacePutID
-> Room -> Room
-> Room -> Room
replacePutID i psts r = replacePutID i psts r =
r & rmPS %~ flip (subZipWith (isPutID i) (\ps pt -> ps & plType .~ pt)) psts r & rmPmnts %~ flip (subZipWith (isPutID i) (\ps pt -> ps & plType .~ pt)) psts
{- Partition a list by a predicate, apply a zip to those elements {- Partition a list by a predicate, apply a zip to those elements
that satisfy the predicate, concatenate that satisfy the predicate, concatenate
the new zipped list and the other (unchanged) half. -} the new zipped list and the other (unchanged) half. -}
src/Dodge/Room.hs
+31 -33
View File
@@ -41,7 +41,7 @@ roomC w h = do
, windowLine (V2 (w/2) 0) (V2 (w/2) (h-60)) , windowLine (V2 (w/2) 0) (V2 (w/2) (h-60))
] ]
changeLinkFrom fromCond $ roomRectAutoLinks w h changeLinkFrom fromCond $ roomRectAutoLinks w h
& rmPS %~ (wl : ) & rmPmnts %~ (wl : )
& rmRandPSs .~ [farside] & rmRandPSs .~ [farside]
where where
fromCond (V2 x _,_) = x < w / 2 - 10 fromCond (V2 x _,_) = x < w / 2 - 10
@@ -56,11 +56,9 @@ roomPadCut ps p = defaultRoom
{ _rmPolys = [ps] { _rmPolys = [ps]
, _rmLinks = [(p,0),(V2 0 0,pi)] , _rmLinks = [(p,0),(V2 0 0,pi)]
, _rmPath = [(V2 0 0,p)] , _rmPath = [(V2 0 0,p)]
, _rmPS = []
, _rmBound = []
} }
roomPillars :: Room roomPillars :: Room
roomPillars = over rmLinks init $ set rmPS plmnts $ roomRect 240 240 2 2 roomPillars = over rmLinks init $ set rmPmnts plmnts $ roomRect 240 240 2 2
where where
plmnts = spanLightI (V2 120 24) (V2 120 216) plmnts = spanLightI (V2 120 24) (V2 120 216)
: mountLightV (V2 12 12) (V3 25 25 70) : mountLightV (V2 12 12) (V3 25 25 70)
@@ -86,8 +84,8 @@ glassLesson = do
return $ Node (Left botRoom) [deadRoom door,uppers, treeFromPost (Left door : corridors) $ Right door] return $ Node (Left botRoom) [deadRoom door,uppers, treeFromPost (Left door : corridors) $ Right door]
where where
uppers = Node (Left door) [deadRoom topRoom] uppers = Node (Left door) [deadRoom topRoom]
botRoom = set rmPS botplmnts $ roomRect 200 200 1 1 botRoom = set rmPmnts botplmnts $ roomRect 200 200 1 1
topRoom = set rmPS topplmnts $ roomRect 200 200 1 1 topRoom = set rmPmnts topplmnts $ roomRect 200 200 1 1
botplmnts = botplmnts =
[sPS (V2 0 0) 0 $ PutWall (rectNSWE 200 0 90 110) defaultCrystalWall [sPS (V2 0 0) 0 $ PutWall (rectNSWE 200 0 90 110) defaultCrystalWall
,sPS (V2 50 100) 0 $ PutCrit miniGunCrit ,sPS (V2 50 100) 0 $ PutCrit miniGunCrit
@@ -134,12 +132,12 @@ glassSwitchBack = do
return (V2 crx cry,1.5*pi) return (V2 crx cry,1.5*pi)
midPS = return (V2 (wth-20) (hgt/2+40), pi) midPS = return (V2 (wth-20) (hgt/2+40), pi)
return $ roomRect wth hgt 2 4 return $ roomRect wth hgt 2 4
& rmPS .~ plmnts & rmPmnts .~ plmnts
& rmRandPSs .~ [northPSs,midPS] & rmRandPSs .~ [northPSs,midPS]
glassSwitchBackCrits :: RandomGen g => State g Room glassSwitchBackCrits :: RandomGen g => State g Room
glassSwitchBackCrits = glassSwitchBack glassSwitchBackCrits = glassSwitchBack
<&> rmPS %~ ([Placement (PSRoomRand 0) (PutCrit miniGunCrit) (const Nothing) <&> rmPmnts %~ ([Placement (PSRoomRand 0) (PutCrit miniGunCrit) (const Nothing)
, Placement (PSRoomRand 1) randC1 (const Nothing) , Placement (PSRoomRand 1) randC1 (const Nothing)
] ++) ] ++)
@@ -178,7 +176,7 @@ miniRoom3 = do
,sPS cp (pi/8+7*pi/4) b ,sPS cp (pi/8+7*pi/4) b
,sPS (V2 (w/2) (h/2)) 0 putLamp ,sPS (V2 (w/2) (h/2)) 0 putLamp
] ]
fmap connectRoom $ randomiseOutLinks $ set rmPS plmnts $ roomRectAutoLinks w h fmap connectRoom $ randomiseOutLinks $ set rmPmnts plmnts $ roomRectAutoLinks w h
rot90Around :: Point2 -> Point2 -> Point2 rot90Around :: Point2 -> Point2 -> Point2
rot90Around cen p = cen +.+ vNormal (p -.- cen) rot90Around cen p = cen +.+ vNormal (p -.- cen)
@@ -200,7 +198,7 @@ roomMiniIntro = fmap (g . expandTreeBy f) $ sequence $ treeFromPost
roomCenterPillar :: RandomGen g => State g Room roomCenterPillar :: RandomGen g => State g Room
roomCenterPillar = changeLinkTo ((\p -> dist p (V2 120 0) < 10) . fst) roomCenterPillar = changeLinkTo ((\p -> dist p (V2 120 0) < 10) . fst)
$ set rmPS plmnts $ roomRect 240 240 2 2 $ set rmPmnts plmnts $ roomRect 240 240 2 2
where where
plmnts = plmnts =
[ blockLine (V2 115 115) (V2 115 125) [ blockLine (V2 115 115) (V2 115 125)
@@ -216,7 +214,7 @@ roomOctogon = defaultRoom
{ _rmPolys = [poly ] { _rmPolys = [poly ]
, _rmLinks = lnks , _rmLinks = lnks
, _rmPath = allPairs $ map fst lnks -- this is too much , _rmPath = allPairs $ map fst lnks -- this is too much
, _rmPS = [] , _rmPmnts = []
, _rmBound = [map toV2 [(-20,30),(20,30),(60,70),(60,110),(20,150),(-20,150),(-60,110),(-60,70)] ] , _rmBound = [map toV2 [(-20,30),(20,30),(60,70),(60,110),(20,150),(-20,150),(-60,110),(-60,70)] ]
, _rmFloor = [makeTileFromPoly poly 7] , _rmFloor = [makeTileFromPoly poly 7]
} }
@@ -260,7 +258,7 @@ weaponEmptyRoom = do
,mntLightLnkCond (const True) ,mntLightLnkCond (const True)
] ]
(fmap connectRoom . randomiseOutLinks) =<< (fmap connectRoom . randomiseOutLinks) =<<
changeLinkTo ((\p -> dist p (V2 (w/2) 0) < 10) . fst) (set rmPS plmnts $ roomRect w h 2 2) changeLinkTo ((\p -> dist p (V2 (w/2) 0) < 10) . fst) (set rmPmnts plmnts $ roomRect w h 2 2)
weaponUnderCrits :: RandomGen g => State g (Tree (Either Room Room)) weaponUnderCrits :: RandomGen g => State g (Tree (Either Room Room))
weaponUnderCrits = do weaponUnderCrits = do
@@ -271,7 +269,7 @@ weaponUnderCrits = do
] ]
let continuationRoom = treeFromTrunk let continuationRoom = treeFromTrunk
[Left corridorN,Left corridorN] [Left corridorN,Left corridorN]
(connectRoom (set rmPS plmnts corridorN)) (connectRoom (set rmPmnts plmnts corridorN))
rcp <- roomCenterPillar rcp <- roomCenterPillar
deadEndRoom' <- takeOne [roomPillars,rcp] deadEndRoom' <- takeOne [roomPillars,rcp]
junctionRoom <- takeOne [Left tEast,Left tWest] junctionRoom <- takeOne [Left tEast,Left tWest]
@@ -292,9 +290,9 @@ weaponBehindPillar = do
rcp <- roomCenterPillar rcp <- roomCenterPillar
return $ treeFromTrunk return $ treeFromTrunk
[Left door [Left door
,Left $ over rmLinks tail $ over rmPS (++ plmnts1) rcp ,Left $ over rmLinks tail $ over rmPmnts (++ plmnts1) rcp
] ]
(connectRoom $ set rmPS [sPS (V2 20 60) (negate $ pi/2) randC1] corridorN) (connectRoom $ set rmPmnts [sPS (V2 20 60) (negate $ pi/2) randC1] corridorN)
weaponBetweenPillars :: RandomGen g => State g (Tree (Either Room Room)) weaponBetweenPillars :: RandomGen g => State g (Tree (Either Room Room))
weaponBetweenPillars = do weaponBetweenPillars = do
@@ -307,7 +305,7 @@ weaponBetweenPillars = do
,sPS crPos1 (d crPos1) randC1 ,sPS crPos1 (d crPos1) randC1
,sPS crPos2 (d crPos2) randC1 ,sPS crPos2 (d crPos2) randC1
] ]
theRoom = roomPillars & rmPS %~ (++ plmnts) theRoom = roomPillars & rmPmnts %~ (++ plmnts)
(fmap connectRoom . randomiseOutLinks) =<< filterLinks f theRoom (fmap connectRoom . randomiseOutLinks) =<< filterLinks f theRoom
where where
f (_,a) = a == 0 f (_,a) = a == 0
@@ -316,7 +314,7 @@ weaponLongCorridor :: RandomGen g => State g (Tree (Either Room Room))
weaponLongCorridor = do weaponLongCorridor = do
root <- takeOne [tEast, tWest] root <- takeOne [tEast, tWest]
connectingRoom <- takeOne connectingRoom <- takeOne
[tEast & rmPS .~ [spanLightI (V2 (-40) 40) (V2 (-40) 80)] [tEast & rmPmnts .~ [spanLightI (V2 (-40) 40) (V2 (-40) 80)]
] ]
i1 <- state $ randomR (2,5) i1 <- state $ randomR (2,5)
i2 <- state $ randomR (2,5) i2 <- state $ randomR (2,5)
@@ -324,11 +322,11 @@ weaponLongCorridor = do
let branch2 = treeFromTrunk (replicate i2 $ Left corridorN) (deadRoom $ putWp corridor) let branch2 = treeFromTrunk (replicate i2 $ Left corridorN) (deadRoom $ putWp corridor)
return $ Node (Left root) [branch1,branch2] return $ Node (Left root) [branch1,branch2]
where where
putCrs = over rmPS (++ [sPS (V2 10 40) (-pi/2) randC1 ,sPS (V2 (-10) 40) (-pi/2) randC1 ]) putCrs = over rmPmnts (++ [sPS (V2 10 40) (-pi/2) randC1 ,sPS (V2 (-10) 40) (-pi/2) randC1 ])
putWp = set rmPS [sPS (V2 20 60) 0 $ RandPS randFirstWeapon ,spanLightI (V2 0 40) (V2 40 40)] putWp = set rmPmnts [sPS (V2 20 60) 0 $ RandPS randFirstWeapon ,spanLightI (V2 0 40) (V2 40 40)]
critInDeadEnd :: Room critInDeadEnd :: Room
critInDeadEnd = set rmPS [sPS (V2 0 0) 0 randC1] deadEndRoom critInDeadEnd = set rmPmnts [sPS (V2 0 0) 0 randC1] deadEndRoom
deadEndRoom :: Room deadEndRoom :: Room
deadEndRoom = defaultRoom deadEndRoom = defaultRoom
@@ -336,7 +334,7 @@ deadEndRoom = defaultRoom
] ]
, _rmLinks = lnks , _rmLinks = lnks
, _rmPath = [] , _rmPath = []
, _rmPS = [sPS (V2 0 (-10)) 0 putLamp] , _rmPmnts = [sPS (V2 0 (-10)) 0 putLamp]
, _rmBound = [rectNSWE 20 (-20) (-30) 30] , _rmBound = [rectNSWE 20 (-20) (-30) 30]
} }
where where
@@ -353,7 +351,7 @@ weaponRoom = join $ takeOne
roomCCrits :: RandomGen g => State g Room roomCCrits :: RandomGen g => State g Room
roomCCrits = roomC 200 200 roomCCrits = roomC 200 200
<&> rmPS %~ (replicate 20 (Placement (PSRoomRand 0) randC1 (const Nothing)) ++ ) <&> rmPmnts %~ (replicate 20 (Placement (PSRoomRand 0) randC1 (const Nothing)) ++ )
longRoom :: RandomGen g => State g Room longRoom :: RandomGen g => State g Room
longRoom = do longRoom = do
@@ -373,7 +371,7 @@ longRoom = do
brls <- fmap (map (\p -> sPS (p +.+ V2 10 200) 0 $ PutCrit explosiveBarrel) ) brls <- fmap (map (\p -> sPS (p +.+ V2 10 200) 0 $ PutCrit explosiveBarrel) )
$ replicateM 5 $ randInRect (w-20) 900 $ replicateM 5 $ randInRect (w-20) 900
let rm = roomRect w (h+70) 1 1 & rmPolys %~ ([rectNSWE h (h-165) (-45) (w+45)] ++) let rm = roomRect w (h+70) 1 1 & rmPolys %~ ([rectNSWE h (h-165) (-45) (w+45)] ++)
changeLinkTo cond $ rm & rmPS .~ ws ++ brls ++ wsDefense ++ changeLinkTo cond $ rm & rmPmnts .~ ws ++ brls ++ wsDefense ++
[sPS (V2 12.5 (h-25)) 0 $ PutCrit longCrit [sPS (V2 12.5 (h-25)) 0 $ PutCrit longCrit
,sPS (V2 37.5 (h-25)) 0 $ PutCrit longCrit ,sPS (V2 37.5 (h-25)) 0 $ PutCrit longCrit
,sPS (V2 62.5 (h-25)) 0 $ PutCrit longCrit ,sPS (V2 62.5 (h-25)) 0 $ PutCrit longCrit
@@ -385,7 +383,7 @@ doubleCorridorBarrels :: RandomGen g => State g Room
doubleCorridorBarrels = do doubleCorridorBarrels = do
h <- state $ randomR (200,300) h <- state $ randomR (200,300)
let cond x = (sndV2 . fst) x < h - 40 let cond x = (sndV2 . fst) x < h - 40
changeLinkTo cond $ roomRect 100 h 1 1 & rmPS .~ changeLinkTo cond $ roomRect 100 h 1 1 & rmPmnts .~
[blockLine (V2 50 50) (V2 50 h) [blockLine (V2 50 50) (V2 50 h)
,sPS (V2 25 (h-25)) 0 $ PutCrit $ addArmour autoCrit ,sPS (V2 25 (h-25)) 0 $ PutCrit $ addArmour autoCrit
,sPS (V2 75 (h-30)) 0 $ PutCrit explosiveBarrel ,sPS (V2 75 (h-30)) 0 $ PutCrit explosiveBarrel
@@ -413,19 +411,19 @@ shootersRoom' = do
,spanLightI (V2 (w/2) 200) (V2 (w+10) 200) ,spanLightI (V2 (w/2) 200) (V2 (w+10) 200)
] ]
toPS x y = return (V2 x y,-0.5*pi) toPS x y = return (V2 x y,-0.5*pi)
return $ set rmPS plmnts $ roomRectAutoLinks w 600 return $ set rmPmnts plmnts $ roomRectAutoLinks w 600
& rmPS .~ plmnts & rmPmnts .~ plmnts
& rmRandPSs .~ [toPS x1 y1,toPS x2 y2,toPS x3 y3] & rmRandPSs .~ [toPS x1 y1,toPS x2 y2,toPS x3 y3]
shootersRoom1 :: RandomGen g => State g Room shootersRoom1 :: RandomGen g => State g Room
shootersRoom1 = shootersRoom' <&> rmPS %~ shootersRoom1 = shootersRoom' <&> rmPmnts %~
( ( ( (
RandomPlacement $ takeOne $ map (\i -> Placement (PSRoomRand i) (PutCrit autoCrit) (const Nothing)) RandomPlacement $ takeOne $ map (\i -> Placement (PSRoomRand i) (PutCrit autoCrit) (const Nothing))
[0,1,2] [0,1,2]
) :) ) :)
shootersRoom :: RandomGen g => State g Room shootersRoom :: RandomGen g => State g Room
shootersRoom = shootersRoom' <&> rmPS %~ shootersRoom = shootersRoom' <&> rmPmnts %~
( map (\i -> Placement (PSRoomRand i) (PutCrit autoCrit) (const Nothing)) ( map (\i -> Placement (PSRoomRand i) (PutCrit autoCrit) (const Nothing))
[0,1,2] [0,1,2]
++ ) ++ )
@@ -456,13 +454,13 @@ pillarGrid = do
++ ++
concat [f x y | x<-xs,y<-ys] concat [f x y | x<-xs,y<-ys]
return $ roomRect w h (max i 2) (max i 2) return $ roomRect w h (max i 2) (max i 2)
& rmPS .~ plmnts & rmPmnts .~ plmnts
& rmRandPSs .~ [rps] & rmRandPSs .~ [rps]
-- TODO remove possible identical draws on random PSs -- TODO remove possible identical draws on random PSs
pistolerRoom :: RandomGen g => State g Room pistolerRoom :: RandomGen g => State g Room
pistolerRoom = pillarGrid pistolerRoom = pillarGrid
<&> rmPS %~ ( <&> rmPmnts %~ (
[Placement (PSRoomRand 0) (PutCrit pistolCrit) (const Nothing) [Placement (PSRoomRand 0) (PutCrit pistolCrit) (const Nothing)
,Placement (PSRoomRand 0) (PutCrit pistolCrit) (const Nothing) ,Placement (PSRoomRand 0) (PutCrit pistolCrit) (const Nothing)
,Placement (PSRoomRand 0) (PutCrit pistolCrit) (const Nothing) ,Placement (PSRoomRand 0) (PutCrit pistolCrit) (const Nothing)
@@ -480,10 +478,10 @@ shootingRange = do
return $ treeFromPost return $ treeFromPost
[Left rm1 [Left rm1
,Left $ roomPadCut (rectNSWE 40 (-40) (-80) 80) (V2 0 20) ,Left $ roomPadCut (rectNSWE 40 (-40) (-80) 80) (V2 0 20)
& rmPS %~ (spanLightI (V2 (-80) 10) (V2 80 10) :) & rmPmnts %~ (spanLightI (V2 (-80) 10) (V2 80 10) :)
,Left rm2 ,Left rm2
,Left $ roomPadCut (rectNSWE 40 (-40) (-80) 80) (V2 0 20) ,Left $ roomPadCut (rectNSWE 40 (-40) (-80) 80) (V2 0 20)
& rmPS %~ (spanLightI (V2 (-80) 10) (V2 80 10) :) & rmPmnts %~ (spanLightI (V2 (-80) 10) (V2 80 10) :)
] ]
(Right rm3) (Right rm3)
@@ -492,6 +490,6 @@ spawnerRoom = do
x <- state $ randomR (250,300) x <- state $ randomR (250,300)
y <- state $ randomR (300,400) y <- state $ randomR (300,400)
roomWithSpawner <- roomC x y <&> roomWithSpawner <- roomC x y <&>
rmPS %~ (Placement (PSRoomRand 0) (PutCrit spawnerCrit) (const Nothing) :) rmPmnts %~ (Placement (PSRoomRand 0) (PutCrit spawnerCrit) (const Nothing) :)
aRoom <- airlock aRoom <- airlock
return $ treeFromTrunk [Left aRoom,Left corridor] $ connectRoom roomWithSpawner return $ treeFromTrunk [Left aRoom,Left corridor] $ connectRoom roomWithSpawner
src/Dodge/Room/Airlock.hs
+5 -5
View File
@@ -26,7 +26,7 @@ airlock0 = defaultRoom
{ _rmPolys = [ rectNSWE 100 0 0 40 , rectNSWE 65 35 (-40) 20 ] { _rmPolys = [ rectNSWE 100 0 0 40 , rectNSWE 65 35 (-40) 20 ]
, _rmLinks = lnks , _rmLinks = lnks
, _rmPath = [(V2 20 95,V2 20 45) ,(V2 20 45,V2 20 5) ] , _rmPath = [(V2 20 95,V2 20 45) ,(V2 20 45,V2 20 5) ]
, _rmPS = , _rmPmnts =
[Placement (PS (V2 (-35) 50) (negate $ pi/2)) (PutButton $ makeSwitch col red id id) [Placement (PS (V2 (-35) 50) (negate $ pi/2)) (PutButton $ makeSwitch col red id id)
$ \btid -> Just $ putDoubleDoorThen False col (not . cond' btid) (V2 (-1) 20) (V2 41 20) 2 $ \btid -> Just $ putDoubleDoorThen False col (not . cond' btid) (V2 (-1) 20) (V2 41 20) 2
$ Just $ putDoubleDoorThen False col (cond' btid) (V2 (-1) 80) (V2 41 80) 2 Nothing $ Just $ putDoubleDoorThen False col (cond' btid) (V2 (-1) 80) (V2 41 80) 2 Nothing
@@ -48,7 +48,7 @@ airlockSimple = defaultRoom
[ rectNSWE 120 0 0 180 ] [ rectNSWE 120 0 0 180 ]
, _rmLinks = lnks , _rmLinks = lnks
, _rmPath = concatMap (doublePair. (V2 90 30,) . fst) lnks , _rmPath = concatMap (doublePair. (V2 90 30,) . fst) lnks
, _rmPS = , _rmPmnts =
[ Placement (PS (V2 90 115) pi) (PutButton $ makeSwitch col red id id) [ Placement (PS (V2 90 115) pi) (PutButton $ makeSwitch col red id id)
$ \btid -> jspsJ (V2 0 0) 0 (PutDoor col (cond btid) outDoorps) $ \btid -> jspsJ (V2 0 0) 0 (PutDoor col (cond btid) outDoorps)
$ sPS (V2 180 0) 0 (PutDoor col (cond btid) inDoorps) $ sPS (V2 180 0) 0 (PutDoor col (cond btid) inDoorps)
@@ -77,7 +77,7 @@ airlockZ = defaultRoom
-- [(V2 0 40,V2 40 0) -- [(V2 0 40,V2 40 0)
-- ,(V2 40 0,V2 0 40) -- ,(V2 40 0,V2 0 40)
-- ] -- ]
, _rmPS = , _rmPmnts =
[ Placement (PS (V2 90 115) pi) (PutButton $ makeSwitch col red id id) [ Placement (PS (V2 90 115) pi) (PutButton $ makeSwitch col red id id)
$ \btid -> jspsJ (V2 0 60) 0 (PutDoor col (cond btid) outDoorps) $ \btid -> jspsJ (V2 0 60) 0 (PutDoor col (cond btid) outDoorps)
$ sPS (V2 180 60) 0 (PutDoor col (cond btid) inDoorps) $ sPS (V2 180 60) 0 (PutDoor col (cond btid) inDoorps)
@@ -117,7 +117,7 @@ airlock90 = defaultRoom
[(V2 0 40,V2 40 0) [(V2 0 40,V2 40 0)
,(V2 40 0,V2 0 40) ,(V2 40 0,V2 0 40)
] ]
, _rmPS = , _rmPmnts =
[ Placement (PS (V2 120 120) (3 * pi/4)) (PutButton $ makeSwitch col red id id) [ Placement (PS (V2 120 120) (3 * pi/4)) (PutButton $ makeSwitch col red id id)
$ \btid -> jsps (V2 5 5) 0 $ PutDoor col (cond btid) pss $ \btid -> jsps (V2 5 5) 0 $ PutDoor col (cond btid) pss
,mountLightV (V2 20 20) (V3 70 70 50) ,mountLightV (V2 20 20) (V3 70 70 50)
@@ -145,7 +145,7 @@ airlockCrystal = defaultRoom
] ]
, _rmLinks = [(V2 20 130,0) ,(V2 20 0 ,pi) ] , _rmLinks = [(V2 20 130,0) ,(V2 20 0 ,pi) ]
, _rmPath = [ ] , _rmPath = [ ]
, _rmPS = , _rmPmnts =
[ Placement (PS (V2 145 70) (pi/2)) ( PutButton $ makeSwitch col red id id) [ Placement (PS (V2 145 70) (pi/2)) ( PutButton $ makeSwitch col red id id)
$ \btid -> jsps0 $ PutDoor col (cond btid) pss $ \btid -> jsps0 $ PutDoor col (cond btid) pss
, crystalLine (V2 0 70) (V2 40 70) , crystalLine (V2 0 70) (V2 40 70)
src/Dodge/Room/Boss.hs
+6 -6
View File
@@ -34,7 +34,7 @@ roomGlassOctogon x = createPathGrid $ defaultRoom
[ ( V2 0 x , V2 0 (-(x+40))) [ ( V2 0 x , V2 0 (-(x+40)))
, ( V2 0 (-(x+40)), V2 0 x) , ( V2 0 (-(x+40)), V2 0 x)
] ]
, _rmPS = , _rmPmnts =
[sPS (V2 fx fx) 0 putLamp [sPS (V2 fx fx) 0 putLamp
,sPS (V2 (-fx) fx) 0 putLamp ,sPS (V2 (-fx) fx) 0 putLamp
,sPS (V2 fx (-fx)) 0 putLamp ,sPS (V2 fx (-fx)) 0 putLamp
@@ -55,14 +55,14 @@ roomGlassOctogon x = createPathGrid $ defaultRoom
] ]
bossRoom :: RandomGen g => Creature -> State g Room bossRoom :: RandomGen g => Creature -> State g Room
bossRoom cr = randomMediumRoom <&> rmPS %~ ( sPS (V2 0 100) (negate $ pi/2) (PutCrit cr) :) bossRoom cr = randomMediumRoom <&> rmPmnts %~ ( sPS (V2 0 100) (negate $ pi/2) (PutCrit cr) :)
armouredChasers :: RandomGen g => State g (Tree Room) armouredChasers :: RandomGen g => State g (Tree Room)
armouredChasers = do armouredChasers = do
ps <- takeN 5 [V2 x y | x <- [-100,-80 .. 100] ,y <- [-100,-80 .. 100] ] ps <- takeN 5 [V2 x y | x <- [-100,-80 .. 100] ,y <- [-100,-80 .. 100] ]
as <- replicateM 5 . state $ randomR (0,2*pi) as <- replicateM 5 . state $ randomR (0,2*pi)
let theCrits = zipWith3 (\p a c -> sPS p a (PutCrit c)) ps as cs let theCrits = zipWith3 (\p a c -> sPS p a (PutCrit c)) ps as cs
treeFromPost [corridor,corridor] <$> (randomMediumRoom <&> rmPS %~ (++ theCrits)) treeFromPost [corridor,corridor] <$> (randomMediumRoom <&> rmPmnts %~ (++ theCrits))
where where
cs = (armourChaseCrit & crState . crDropsOnDeath .~ DropSpecific [0]) cs = (armourChaseCrit & crState . crDropsOnDeath .~ DropSpecific [0])
: replicate 4 chaseCrit : replicate 4 chaseCrit
@@ -94,7 +94,7 @@ roomCross x y = defaultRoom
,(V2 (y-20) (-x),pi) ,(V2 (y-20) (-x),pi)
] ]
, _rmPath = [] , _rmPath = []
, _rmPS = , _rmPmnts =
[ spanLightI (V2 (x+5) x) (V2 (x+5) (-x)) [ spanLightI (V2 (x+5) x) (V2 (x+5) (-x))
, spanLightI (V2 (-x-5) x) (V2 (-x-5) (-x)) , spanLightI (V2 (-x-5) x) (V2 (-x-5) (-x))
] ]
@@ -119,7 +119,7 @@ roomShuriken x y =
{ _rmPolys = ps { _rmPolys = ps
, _rmLinks = [(V2 (x-1) (y-20),negate $ pi/2)] , _rmLinks = [(V2 (x-1) (y-20),negate $ pi/2)]
, _rmPath = [] , _rmPath = []
, _rmPS = [mountLight (V2 x x) (V3 (x-20) x 70)] , _rmPmnts = [mountLight (V2 x x) (V3 (x-20) x 70)]
, _rmBound = ps , _rmBound = ps
} }
in foldr1 combineRooms $ map (\r -> shiftRoomBy (V2 0 0, r) corner) [0,pi/2,pi,3*pi/2] in foldr1 combineRooms $ map (\r -> shiftRoomBy (V2 0 0, r) corner) [0,pi/2,pi,3*pi/2]
@@ -143,7 +143,7 @@ roomTwistCross x y z =
{ _rmPolys = ps { _rmPolys = ps
, _rmLinks = [(V2 z (y-20), pi/2)] , _rmLinks = [(V2 z (y-20), pi/2)]
, _rmPath = [] , _rmPath = []
, _rmPS = [mountLight (V2 x x) (V3 (x-20) (x-20) 70)] , _rmPmnts = [mountLight (V2 x x) (V3 (x-20) (x-20) 70)]
, _rmBound = ps , _rmBound = ps
} }
in foldr1 combineRooms $ map (\r -> shiftRoomBy (V2 0 0, r) corner) [0,pi/2,pi,3*pi/2] in foldr1 combineRooms $ map (\r -> shiftRoomBy (V2 0 0, r) corner) [0,pi/2,pi,3*pi/2]
src/Dodge/Room/Corridor.hs
+5 -5
View File
@@ -17,7 +17,7 @@ corridor = defaultRoom
{ _rmPolys = [poly] { _rmPolys = [poly]
, _rmLinks = lnks , _rmLinks = lnks
, _rmPath = concatMap (doublePair . (,) (V2 20 60) . fst) lnks , _rmPath = concatMap (doublePair . (,) (V2 20 60) . fst) lnks
, _rmPS = [ spanLightI (V2 0 40) (V2 40 40) ] , _rmPmnts = [ spanLightI (V2 0 40) (V2 40 40) ]
, _rmBound = [ rectNSWE 50 30 0 40 ] , _rmBound = [ rectNSWE 50 30 0 40 ]
, _rmFloor = [makeTileFromPoly poly 2] , _rmFloor = [makeTileFromPoly poly 2]
} }
@@ -39,7 +39,7 @@ corridorDebug = defaultRoom
] ]
, _rmLinks = lnks , _rmLinks = lnks
, _rmPath = concatMap (doublePair . (,) (V2 20 60) . fst) lnks , _rmPath = concatMap (doublePair . (,) (V2 20 60) . fst) lnks
, _rmPS = [] , _rmPmnts = []
, _rmBound = [ rectNSWE 50 30 0 40 ] , _rmBound = [ rectNSWE 50 30 0 40 ]
} }
where where
@@ -55,7 +55,7 @@ corridorN = defaultRoom
] ]
, _rmLinks = lnks , _rmLinks = lnks
, _rmPath = pth , _rmPath = pth
, _rmPS = [] , _rmPmnts = []
, _rmBound = [ rectNSWE 50 30 0 40 ] , _rmBound = [ rectNSWE 50 30 0 40 ]
} }
where lnks = [(V2 20 70 ,0) where lnks = [(V2 20 70 ,0)
@@ -70,7 +70,7 @@ tEast = defaultRoom
] ]
, _rmLinks = lnks , _rmLinks = lnks
, _rmPath = concatMap (doublePair . (,) (V2 0 60) . fst) lnks , _rmPath = concatMap (doublePair . (,) (V2 0 60) . fst) lnks
, _rmPS = [] , _rmPmnts = []
, _rmBound = [ rectNSWE 70 10 0 40 ] , _rmBound = [ rectNSWE 70 10 0 40 ]
} }
where where
@@ -86,7 +86,7 @@ tWest = defaultRoom
] ]
, _rmLinks = lnks , _rmLinks = lnks
, _rmPath = concatMap (doublePair . (,) (V2 0 60) . fst) lnks , _rmPath = concatMap (doublePair . (,) (V2 0 60) . fst) lnks
, _rmPS = [] , _rmPmnts = []
, _rmBound = [ rectNSWE 70 10 0 40 ] , _rmBound = [ rectNSWE 70 10 0 40 ]
} }
where where
src/Dodge/Room/Data.hs
+10 -5
View File
@@ -9,6 +9,7 @@ import Data.Tile
import Control.Monad.State import Control.Monad.State
import System.Random import System.Random
import Control.Lens import Control.Lens
import qualified Data.IntMap.Strict as IM
{- {-
The '_rmPolys' list states which polygons should be cut out to form the indestructible walls of the room. The '_rmPolys' list states which polygons should be cut out to form the indestructible walls of the room.
Link pairs contain a position and rotation to attach to another room; Link pairs contain a position and rotation to attach to another room;
@@ -21,9 +22,11 @@ assigning no bounds will allow rooms to overlap.
data Room = Room data Room = Room
{ _rmPolys :: [ [Point2] ] { _rmPolys :: [ [Point2] ]
, _rmLinks :: [(Point2,Float)] , _rmLinks :: [(Point2,Float)]
, _rmUsedLinks :: [(Point2,Float)] , _rmUsedLinks :: [RoomPos]
, _rmPath :: [(Point2, Point2)] , _rmPath :: [(Point2, Point2)]
, _rmPS :: [Placement] , _rmPmnts :: [Placement]
, _rmLabelledPmnts :: IM.IntMap Placement
, _rmPartialPmnts :: IM.IntMap (Int -> Placement)
, _rmBound :: [ [Point2] ] , _rmBound :: [ [Point2] ]
, _rmFloor :: [Tile] , _rmFloor :: [Tile]
, _rmName :: String , _rmName :: String
@@ -32,7 +35,9 @@ data Room = Room
, _rmRandPSs :: [State StdGen (Point2,Float)] , _rmRandPSs :: [State StdGen (Point2,Float)]
} }
data RoomPos data RoomPos
= Link (Point2,Float) = OutLink Int Point2 Float
| UsedLink (Point2,Float) | InLink Point2 Float
| LinkInt Int (Point2,Float) | PosInt Int Point2 Float
| PosPl Point2 Float
deriving (Eq,Ord,Show)
makeLenses ''Room makeLenses ''Room
src/Dodge/Room/Door.hs
+2 -2
View File
@@ -14,8 +14,8 @@ door = defaultRoom
, _rmLinks = lnks , _rmLinks = lnks
, _rmPath = [(V2 20 35,V2 20 5)] , _rmPath = [(V2 20 35,V2 20 5)]
-- door extends into side walls (for shadows as rendered 12/03) -- door extends into side walls (for shadows as rendered 12/03)
, _rmPS = [putAutoDoor (V2 0 20) (V2 40 20)] , _rmPmnts = [putAutoDoor (V2 0 20) (V2 40 20)]
, _rmBound = [] -- note no bounds
} }
where lnks = [(V2 20 35,0) where lnks = [(V2 20 35,0)
,(V2 20 5,pi) ,(V2 20 5,pi)
src/Dodge/Room/Link.hs
+8
View File
@@ -15,6 +15,7 @@ module Dodge.Room.Link
, randomiseOutLinks , randomiseOutLinks
, randomiseLinksBy , randomiseLinksBy
, invShiftLinkBy , invShiftLinkBy
, setLastLinkToUsed
) where ) where
import Dodge.LevelGen import Dodge.LevelGen
import Dodge.Room.Data import Dodge.Room.Data
@@ -105,3 +106,10 @@ shiftPathBy
-> (Point2,Point2) -> (Point2,Point2)
-> (Point2,Point2) -> (Point2,Point2)
shiftPathBy s (p1,p2) = (shiftPointBy s p1, shiftPointBy s p2) shiftPathBy s (p1,p2) = (shiftPointBy s p1, shiftPointBy s p2)
setLastLinkToUsed :: Room -> Room
setLastLinkToUsed rm = case _rmLinks rm of
(_:_) -> rm
& rmLinks %~ init
& rmUsedLinks %~ (uncurry InLink (last (_rmLinks rm)) :)
_ -> rm
src/Dodge/Room/LongDoor.hs
+6 -6
View File
@@ -38,7 +38,7 @@ twinSlowDoorRoom w h x = defaultRoom
, (V2 0 (-h), pi) , (V2 0 (-h), pi)
] ]
, _rmPath = [] , _rmPath = []
, _rmPS = , _rmPmnts =
[ Placement (PS (V2 0 (h-5)) pi) ( PutButton $ makeButton col id) [ Placement (PS (V2 0 (h-5)) pi) ( PutButton $ makeButton col id)
$ \btid -> jsps0J (PutSlideDoor False col (cond' btid) (V2 x 1) (V2 x h) wlSpeed) $ \btid -> jsps0J (PutSlideDoor False col (cond' btid) (V2 x 1) (V2 x h) wlSpeed)
$ ps0 (PutSlideDoor False col (cond' btid) (V2 (-x) 1) (V2 (-x) h) wlSpeed) $ ps0 (PutSlideDoor False col (cond' btid) (V2 (-x) 1) (V2 (-x) h) wlSpeed)
@@ -73,7 +73,7 @@ twinSlowDoorChasers = do
rps = V2 65 <$> [20,40 .. 180] rps = V2 65 <$> [20,40 .. 180]
ps <- takeN 4 $ lps ++ rps ps <- takeN 4 $ lps ++ rps
let plmnts = map (\p -> sPS p 0 $ PutCrit chaseCrit) ps let plmnts = map (\p -> sPS p 0 $ PutCrit chaseCrit) ps
return $ twinSlowDoorRoom 80 200 40 & rmPS %~ (plmnts ++) return $ twinSlowDoorRoom 80 200 40 & rmPmnts %~ (plmnts ++)
southPillarsRoom :: RandomGen g => Float -> Float -> Float -> State g Room southPillarsRoom :: RandomGen g => Float -> Float -> Float -> State g Room
southPillarsRoom x y h = do southPillarsRoom x y h = do
@@ -85,7 +85,7 @@ southPillarsRoom x y h = do
pillarsc = putBlockRect (x/3-20) (x/3+20) (h/2-20) (h/2+20) pillarsc = putBlockRect (x/3-20) (x/3+20) (h/2-20) (h/2+20)
++ putBlockRect (2*x/3-20) (2*x/3+20) (h/2-20) (h/2+20) ++ putBlockRect (2*x/3-20) (2*x/3+20) (h/2-20) (h/2+20)
pillars <- takeOne [pillarsa, pillarsb, pillarsc] pillars <- takeOne [pillarsa, pillarsb, pillarsc]
return $ roomRectAutoLinks x y & rmPS .~ pillars return $ roomRectAutoLinks x y & rmPmnts .~ pillars
addSouthPillars :: RandomGen g => Float -> Float -> Room -> State g Room addSouthPillars :: RandomGen g => Float -> Float -> Room -> State g Room
addSouthPillars x h r = do addSouthPillars x h r = do
@@ -97,7 +97,7 @@ addSouthPillars x h r = do
pillarsc = putBlockRect (x/3-20) (x/3+20) (h/2-20) (h/2+20) pillarsc = putBlockRect (x/3-20) (x/3+20) (h/2-20) (h/2+20)
++ putBlockRect (2*x/3-20) (2*x/3+20) (h/2-20) (h/2+20) ++ putBlockRect (2*x/3-20) (2*x/3+20) (h/2-20) (h/2+20)
pillars <- takeOne [pillarsa, pillarsb, pillarsc] pillars <- takeOne [pillarsa, pillarsb, pillarsc]
return $ r & rmPS %~ (++ pillars) return $ r & rmPmnts %~ (++ pillars)
addButtonSlowDoor :: RandomGen g => Float -> Float -> Room -> State g Room addButtonSlowDoor :: RandomGen g => Float -> Float -> Room -> State g Room
addButtonSlowDoor x h rm = do addButtonSlowDoor x h rm = do
@@ -107,7 +107,7 @@ addButtonSlowDoor x h rm = do
] ]
thePlacement <- takeOne [butDoor butPos butRot ] thePlacement <- takeOne [butDoor butPos butRot ]
changeLinkFrom aboveH =<< changeLinkTo belowH (rm changeLinkFrom aboveH =<< changeLinkTo belowH (rm
& rmPS %~ (thePlacement :) & rmPmnts %~ (thePlacement :)
& rmBound %~ (openDoorBound :) & rmBound %~ (openDoorBound :)
) )
where where
@@ -138,7 +138,7 @@ slowDoorRoom = do
lsources = [sPS (V2 (x/2) 30) 0 putLamp, sPS (V2 (x/2) (y-30)) 0 putLamp] lsources = [sPS (V2 (x/2) 30) 0 putLamp, sPS (V2 (x/2) (y-30)) 0 putLamp]
barrels = zipWith (\x' y' -> sPS (V2 x' y') 0 $ PutCrit explosiveBarrel) xs' ys' barrels = zipWith (\x' y' -> sPS (V2 x' y') 0 $ PutCrit explosiveBarrel) xs' ys'
proom <- southPillarsRoom x y h proom <- southPillarsRoom x y h
addButtonSlowDoor x h (proom & rmPS %~ (++ (crits ++ barrels ++ lsources))) addButtonSlowDoor x h (proom & rmPmnts %~ (++ (crits ++ barrels ++ lsources)))
randC1 :: PSType randC1 :: PSType
randC1 = RandPS $ takeOne $ map PutCrit $ armourChaseCrit : replicate 50 chaseCrit randC1 = RandPS $ takeOne $ map PutCrit $ armourChaseCrit : replicate 50 chaseCrit
src/Dodge/Room/NoNeedWeapon.hs
+1 -1
View File
@@ -34,5 +34,5 @@ centerVaultExplosiveExit = do
,sPS (V2 0 120) 0 $ PutCrit explosiveBarrel ,sPS (V2 0 120) 0 $ PutCrit explosiveBarrel
,sPS (V2 0 0) 0 $ PutCrit (cr & crState . crDropsOnDeath .~ DropAll) ,sPS (V2 0 0) 0 $ PutCrit (cr & crState . crDropsOnDeath .~ DropAll)
] ]
r <- centerVaultRoom 120 120 50 <&> rmPS %~ (extraPS ++) r <- centerVaultRoom 120 120 50 <&> rmPmnts %~ (extraPS ++)
randomiseLinksBy shuffleTail r <&> rmLinks %~ take 2 randomiseLinksBy shuffleTail r <&> rmLinks %~ take 2
src/Dodge/Room/Procedural.hs
+11 -11
View File
@@ -48,7 +48,7 @@ roomRect x y xn yn = defaultRoom
{ _rmPolys = [rectNSWE y 0 0 x ] { _rmPolys = [rectNSWE y 0 0 x ]
, _rmLinks = lnks , _rmLinks = lnks
, _rmPath = concatMap doublePair pth , _rmPath = concatMap doublePair pth
, _rmPS = [] , _rmPmnts = []
, _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)] , _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)]
, _rmFloor = [Tile , _rmFloor = [Tile
{ _tilePoly = rectNSWE y 0 0 x { _tilePoly = rectNSWE y 0 0 x
@@ -69,7 +69,7 @@ roomRect x y xn yn = defaultRoom
{- Creates a rectangular room, automatically creates links and pathfinding graph at a sensible size. -} {- Creates a rectangular room, automatically creates links and pathfinding graph at a sensible size. -}
roomRectAutoLinks :: Float -> Float -> Room roomRectAutoLinks :: Float -> Float -> Room
roomRectAutoLinks x y = (roomRect x y ((ceiling x - 40) `div` 60) ((ceiling y - 40) `div` 60)) roomRectAutoLinks x y = (roomRect x y ((ceiling x - 40) `div` 60) ((ceiling y - 40) `div` 60))
{_rmPS = plmnts} {_rmPmnts = plmnts}
where where
plmnts = plmnts =
[mntLightLnkCond (const True) [mntLightLnkCond (const True)
@@ -83,8 +83,8 @@ combineRooms r r' = defaultRoom
, _rmLinks = _rmLinks r ++ _rmLinks r' , _rmLinks = _rmLinks r ++ _rmLinks r'
, _rmPath = map clampPath $ _rmPath r , _rmPath = map clampPath $ _rmPath r
++ _rmPath r' ++ _rmPath r'
, _rmPS = map (shiftPlacement $ _rmShift r) (_rmPS r) , _rmPmnts = map (shiftPlacement $ _rmShift r) (_rmPmnts r)
++ map (shiftPlacement $ _rmShift r') (_rmPS r') ++ map (shiftPlacement $ _rmShift r') (_rmPmnts r')
, _rmBound = _rmBound r ++ _rmBound r' , _rmBound = _rmBound r ++ _rmBound r'
, _rmFloor = _rmFloor r ++ _rmFloor r' , _rmFloor = _rmFloor r ++ _rmFloor r'
, _rmShift = (V2 0 0 , 0) , _rmShift = (V2 0 0 , 0)
@@ -126,7 +126,7 @@ quarterRoomFlat w = do
,(V2 0 (w-20),V2 0 0) ,(V2 0 (w-20),V2 0 0)
,(V2 (55-w) (w-20),V2 0 0) ,(V2 (55-w) (w-20),V2 0 0)
] ]
, _rmPS = b , _rmPmnts = b
, _rmBound = [[V2 0 0,V2 w w,V2 (-w) w]] , _rmBound = [[V2 0 0,V2 w w,V2 (-w) w]]
} }
@@ -167,13 +167,13 @@ fourthCornerWall w = do
,(V2 0 0,V2 0 (w-40)) ,(V2 0 0,V2 0 (w-40))
-- ,(V2 (20-w) (w-20),V2 (40-w) (w)) -- ,(V2 (20-w) (w-20),V2 (40-w) (w))
] ]
, _rmPS = b , _rmPmnts = b
, _rmBound = [map toV2 [(w,w),(0,2*w),(-w,w)]] , _rmBound = [map toV2 [(w,w),(0,2*w),(-w,w)]]
} }
{- | Replace the first 'PutNothing' with a given 'PSType'. -} {- | Replace the first 'PutNothing' with a given 'PSType'. -}
fillNothingPlacement :: PSType -> Room -> Room fillNothingPlacement :: PSType -> Room -> Room
fillNothingPlacement pst r = fillNothingPlacement pst r =
r & rmPS %~ replaceNothingWith pst r & rmPmnts %~ replaceNothingWith pst
where where
replaceNothingWith x (Placement (PS p rot) PutNothing _: pss) = sPS p rot x : pss replaceNothingWith x (Placement (PS p rot) PutNothing _: pss) = sPS p rot x : pss
replaceNothingWith x (ps:pss) = ps : replaceNothingWith x pss replaceNothingWith x (ps:pss) = ps : replaceNothingWith x pss
@@ -186,8 +186,8 @@ fillNothingPlacements pst r = foldr fillNothingPlacement r pst
Useful for randomising the position of generic placements such as 'PutNothing'. -} Useful for randomising the position of generic placements such as 'PutNothing'. -}
shufflePlacements :: RandomGen g => Room -> State g Room shufflePlacements :: RandomGen g => Room -> State g Room
shufflePlacements r = do shufflePlacements r = do
newPSs <- shuffle $ _rmPS r newPSs <- shuffle $ _rmPmnts r
return $ r & rmPS .~ newPSs return $ r & rmPmnts .~ newPSs
{- | A randomly generate room based on four randomly generated corners. {- | A randomly generate room based on four randomly generated corners.
Tight corridors, random placements. -} Tight corridors, random placements. -}
randomFourCornerRoom :: RandomGen g => State g Room randomFourCornerRoom :: RandomGen g => State g Room
@@ -201,7 +201,7 @@ randomFourCornerRoom = do
++ replicate 20 chaseCrit ++ replicate 20 chaseCrit
randomiseAllLinks . fillNothingPlacements (crits ++ itms) =<< randomiseAllLinks . fillNothingPlacements (crits ++ itms) =<<
( shufflePlacements ( shufflePlacements
. over rmPS ( sps0 putLamp :) . over rmPmnts ( sps0 putLamp :)
. foldr1 combineRooms . foldr1 combineRooms
$ zipWith (\r a -> shiftRoomBy (V2 0 0,a) r) corners [0,pi/2,pi,3*pi/2] $ zipWith (\r a -> shiftRoomBy (V2 0 0,a) r) corners [0,pi/2,pi,3*pi/2]
) )
@@ -221,7 +221,7 @@ centerVaultRoom w h d = do
,(V2 0 (-h), pi ) ,(V2 0 (-h), pi )
] ]
, _rmPath = [] , _rmPath = []
, _rmPS = , _rmPmnts =
[sps0 $ PutWall (rectNSEW d (d - 30) d (d - 30)) defaultWall [sps0 $ PutWall (rectNSEW d (d - 30) d (d - 30)) defaultWall
,sps0 $ PutWall (rectNSEW d (d - 30) (-d) (30 - d)) defaultWall ,sps0 $ PutWall (rectNSEW d (d - 30) (-d) (30 - d)) defaultWall
,sps0 $ PutWall (rectNSEW (-d) (30 - d) d (d - 30)) defaultWall ,sps0 $ PutWall (rectNSEW (-d) (30 - d) d (d - 30)) defaultWall
src/Dodge/Room/RoadBlock.hs
+4 -4
View File
@@ -41,7 +41,7 @@ litCorridor90 = do
,( V2 0 (h-40) , V2 20 (h-40) ) ,( V2 0 (h-40) , V2 20 (h-40) )
,( V2 40 (h-40) , V2 20 (h-40) ) ,( V2 40 (h-40) , V2 20 (h-40) )
] ]
, _rmPS = , _rmPmnts =
[ sPS (V2 20 (h-5)) 0 putLamp [ sPS (V2 20 (h-5)) 0 putLamp
, spanLightI (V2 0 (0.4*h)) (V2 40 (0.4*h)) , spanLightI (V2 0 (0.4*h)) (V2 40 (0.4*h))
, windowLine (V2 0 (h-20)) (V2 40 (h-20)) , windowLine (V2 0 (h-20)) (V2 40 (h-20))
@@ -63,7 +63,7 @@ longBlockedCorridor = do
,sPS (V2 20 15) 0 putLamp ,sPS (V2 20 15) 0 putLamp
] ]
sequence $ treeFromPost (replicate n $ Left <$> randomiseOutLinks corridor) sequence $ treeFromPost (replicate n $ Left <$> randomiseOutLinks corridor)
$ return $ Right $ set rmPS plmnts corridor $ return $ Right $ set rmPmnts plmnts corridor
-- | A single corridor with a destructible block blocking it. -- | A single corridor with a destructible block blocking it.
blockedCorridor :: RandomGen g => State g (Tree (Either Room Room)) blockedCorridor :: RandomGen g => State g (Tree (Either Room Room))
@@ -74,14 +74,14 @@ blockedCorridor = do
$ reverse $ rectNSWE 10 (-10) (-10) 10 $ reverse $ rectNSWE 10 (-10) (-10) 10
,spanLightI (V2 0 15) (V2 40 15) ,spanLightI (V2 0 15) (V2 40 15)
] ]
sequence $ treeFromPost [] $ return $ Right $ set rmPS plmnts corridor sequence $ treeFromPost [] $ return $ Right $ set rmPmnts plmnts corridor
lasTunnel :: Room lasTunnel :: Room
lasTunnel = defaultRoom lasTunnel = defaultRoom
{ _rmPolys = polys { _rmPolys = polys
, _rmBound = polys , _rmBound = polys
, _rmLinks = [(V2 20 190,1.5* pi),(V2 0 20,0.5* pi)] , _rmLinks = [(V2 20 190,1.5* pi),(V2 0 20,0.5* pi)]
, _rmPS = [putLasTurret & plSpot .~ PS (V2 10 240) (1.5*pi) , _rmPmnts = [putLasTurret & plSpot .~ PS (V2 10 240) (1.5*pi)
, lowWall (rectNSEW 65 40 0 25) , lowWall (rectNSEW 65 40 0 25)
, mountLightV (V2 50 10) (V3 40 20 50) , mountLightV (V2 50 10) (V3 40 20 50)
] ]
src/Dodge/Room/Start.hs
+2 -2
View File
@@ -20,7 +20,7 @@ import System.Random
rezBox :: Room rezBox :: Room
rezBox = shiftRoomBy (V2 (-20) (-10),0) $ roomRect 40 20 1 1 rezBox = shiftRoomBy (V2 (-20) (-10),0) $ roomRect 40 20 1 1
& rmPS .~ [ spanColLightI (V3 0 0.7 0.2) 70 (V2 0 10) (V2 40 10) ] & rmPmnts .~ [ spanColLightI (V3 0 0.7 0.2) 70 (V2 0 10) (V2 40 10) ]
startRoom :: RandomGen g => State g (Tree (Either Room Room)) startRoom :: RandomGen g => State g (Tree (Either Room Room))
startRoom = do startRoom = do
@@ -30,7 +30,7 @@ startRoom = do
girderV 40 20 10 (V2 0 (h/2)) (V2 w (h/2)) girderV 40 20 10 (V2 0 (h/2)) (V2 w (h/2))
treeFromPost [Left rezBox, Left door] . Right treeFromPost [Left rezBox, Left door] . Right
<$> randomiseOutLinks (shiftRoomBy (V2 (-20) (-20),0) <$> randomiseOutLinks (shiftRoomBy (V2 (-20) (-20),0)
$ roomRectAutoLinks w h & rmPS %~ $ roomRectAutoLinks w h & rmPmnts %~
( (
[ fground [ fground
, mountLightJ (V2 0 (h/3)) (V3 40 (h/3) 70) , mountLightJ (V2 0 (h/3)) (V3 40 (h/3) 70)
src/Dodge/Room/Teleport.hs
+1 -1
View File
@@ -22,7 +22,7 @@ telRoomLev
telRoomLev _ = do telRoomLev _ = do
w <- state $ randomR (200,300) w <- state $ randomR (200,300)
h <- state $ randomR (200,300) h <- state $ randomR (200,300)
return $ roomRectAutoLinks w h & rmPS .~ return $ roomRectAutoLinks w h & rmPmnts .~
[ sPS (V2 (w/2) (h/2)) 0 $ PutPressPlate telPP [ sPS (V2 (w/2) (h/2)) 0 $ PutPressPlate telPP
, sPS (V2 (w/2) (h/2+ 30)) 0 putLamp , sPS (V2 (w/2) (h/2+ 30)) 0 putLamp
] ]
src/Dodge/Room/Treasure.hs
+1 -1
View File
@@ -28,7 +28,7 @@ triLootRoom w h = pure $ defaultRoom
] ]
, _rmLinks = [(V2 0 (-80) , pi)] , _rmLinks = [(V2 0 (-80) , pi)]
, _rmPath = doublePair (V2 0 (-80) , V2 0 (h/2)) , _rmPath = doublePair (V2 0 (-80) , V2 0 (h/2))
, _rmPS = , _rmPmnts =
[sPS (V2 (15-w) 15 ) 0 $ PutID 0 [sPS (V2 (15-w) 15 ) 0 $ PutID 0
,sPS (V2 (w-15) 15 ) pi $ PutID 0 ,sPS (V2 (w-15) 15 ) pi $ PutID 0
,sPS (V2 0 (h-35)) 0 $ PutID 2 ,sPS (V2 0 (h-35)) 0 $ PutID 2