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 Dodge.Room.Data
import qualified Data.IntMap.Strict as IM
defaultRoom :: Room
defaultRoom = Room
{ _rmPolys = []
, _rmLinks = []
, _rmUsedLinks = []
, _rmPath = []
, _rmPS = []
, _rmPmnts = []
, _rmPartialPmnts = IM.empty
, _rmLabelledPmnts = IM.empty
, _rmBound = []
, _rmFloor = []
, _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.LongDoor
import Dodge.Room.NoNeedWeapon
import Dodge.Room.Link
import Dodge.Layout.Tree.Polymorphic
import Dodge.Layout.Tree.Either
import Dodge.Layout.Tree.Annotate
@@ -31,16 +32,13 @@ import Control.Monad.Loops
import System.Random
import Data.Sequence hiding (zipWith)
import Data.Maybe
initialAnoTree :: RandomGen g => Tree [Annotation g]
initialAnoTree =
let struct = treeFromPost [[Corridor,SpecificRoom $ fmap (pure . Right) randomFourCornerRoom]] [EndRoom]
t' = padWithCorridors struct
in treeFromTrunk
[[StartRoom]
,[SpecificRoom spawnerRoom]
,[Corridor]
,[Corridor]
,[Corridor]
,[Corridor]
,[SpecificRoom $ return $ connectRoom lasTunnel ]
,[Corridor]
@@ -122,12 +120,12 @@ layoutLevelFromSeed i seed = do
putStr $ "Level generation with seed " ++ show seed ++ " failed: "
let (seed',_) = random g
layoutLevelFromSeed i' seed'
where
setLastLinkToUsed rm = case _rmLinks rm of
(_:_) -> rm
& rmLinks %~ init
& rmUsedLinks %~ (last (_rmLinks rm) :)
_ -> rm
-- where
-- setLastLinkToUsed rm = case _rmLinks rm of
-- (_:_) -> rm
-- & rmLinks %~ init
-- & rmUsedLinks %~ (last (_rmLinks rm) :)
-- _ -> rm
compactDrawTree :: Tree String -> String
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
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 pf PSLnk{_psLinkShift=f} = uncurry PS $ f pf
@@ -117,13 +117,19 @@ gameRoomsFromRooms = map f
f rm = GameRoom
{ _grViewpoints = _rmViewpoints rm ++ (map fst . foldl' (flip cutWalls) [] $ _rmPolys rm)
++ map fst (_rmLinks rm)
, _grViewpointsEx = map fst (_rmUsedLinks rm)
, _grViewpointsEx = mapMaybe unpos (_rmUsedLinks rm)
, _grBound = expandPolyByFixed 100 . convexHullSafe . nubBy closePoints
. concat $ _rmBound rm ++ _rmPolys rm
, _grDir = snd . head $ _rmUsedLinks rm
, _grDir = getDir $ _rmUsedLinks rm
, _grName = _rmName rm
}
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 = concatMap (concatMap tToRender . _rmFloor)
src/Dodge/Layout/Tree/Annotate.hs
+23 -23
View File
@@ -61,26 +61,26 @@ roomThenCorridor theRoom = fmap (\r -> Node (Left theRoom) [(pure . Right) r])
(randomiseOutLinks corridor)
{- | Create a random room tree structure from a list of annotations. -}
annoToRoomTree :: RandomGen g => [Annotation g] -> State g (Tree (Either Room Room))
annoToRoomTree [OrAno as] = do
a <- takeOne as
annoToRoomTree a
annoToRoomTree [Corridor] = pure . Right <$> randomiseOutLinks corridor
annoToRoomTree [CorridorDebug] = pure . Right <$> randomiseOutLinks corridorDebug
annoToRoomTree [DoorAno] = roomThenCorridor door
annoToRoomTree [AirlockAno] = airlock >>= roomThenCorridor
annoToRoomTree [FirstWeapon] = do
branchWP <- branchRectWith weaponRoom
blockedC <- longBlockedCorridor
join $ takeOne $ return (appendEitherTree branchWP [blockedC]) : replicate 5 weaponRoom
annoToRoomTree [EndRoom] = fmap (pure . Right) (telRoomLev 1)
annoToRoomTree [StartRoom] = startRoom
annoToRoomTree (SpecificRoom rt:_) = rt
annoToRoomTree (BossAno cr : _) = do
br <- bossRoom cr
branchRectWith . pure . fmap Left $ treeFromPost [corridor,corridor] br
annoToRoomTree (TreasureAno crs loot : _) =
branchRectWith . fmap (pure . Left) $ lootRoom crs loot
annoToRoomTree _ = do
w <- state $ randomR (100,400)
h <- state $ randomR (200,400)
fmap (pure . Right) . randomiseOutLinks $ roomRectAutoLinks w h
annoToRoomTree anos = case anos of
[OrAno as] -> do
a <- takeOne as
annoToRoomTree a
[Corridor] -> pure . Right <$> randomiseOutLinks corridor
[CorridorDebug] -> pure . Right <$> randomiseOutLinks corridorDebug
[DoorAno] -> roomThenCorridor door
[AirlockAno] -> airlock >>= roomThenCorridor
[FirstWeapon] -> do
branchWP <- branchRectWith weaponRoom
blockedC <- longBlockedCorridor
join $ takeOne $ return (appendEitherTree branchWP [blockedC]) : replicate 5 weaponRoom
[EndRoom] -> fmap (pure . Right) (telRoomLev 1)
[StartRoom] -> startRoom
(SpecificRoom rt:_) -> rt
(BossAno cr : _) -> do
br <- bossRoom cr
branchRectWith . pure . fmap Left $ treeFromPost [corridor,corridor] br
(TreasureAno crs loot : _) -> branchRectWith . fmap (pure . Left) $ lootRoom crs loot
_ -> do
w <- state $ randomR (100,400)
h <- state $ randomR (200,400)
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.
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
( shiftRoomTreeSearchAll
, positionRooms
( positionRooms
) where
import Dodge.Room.Data
import Dodge.Room.Link
@@ -15,34 +12,9 @@ import Geometry.ConvexPoly
import Data.Tree
import Data.Sequence hiding (zipWith)
import Data.List (delete)
--import Data.Maybe (listToMaybe)
import Data.Bifunctor
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 (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
posRms bounds (r,i) (t@(Node (_,i') _):ts) tseq = do
putStr $ "Trying to place room " ++ show i' ++ ": "
tryLinks' (0::Int) (_rmLinks r)
tryLinks (0::Int) (_rmLinks r)
where
tryLinks' _ [] = do
tryLinks _ [] = do
putStrLn "all links tried"
return Nothing
tryLinks' j (l:ls)
| clipping = tryLinks' (j+1) ls
tryLinks j (l:ls)
| clipping = tryLinks (j+1) ls
| otherwise = do
putStrLn $ "placing at link " ++ show j
mayrs <- posRms (convexBounds ++ bounds) useLink ts (tseq |> shiftedt)
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)
where
convexBounds = map pointsToPoly $ _rmBound r'
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)
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
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
that satisfy the predicate, concatenate
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))
]
changeLinkFrom fromCond $ roomRectAutoLinks w h
& rmPS %~ (wl : )
& rmPmnts %~ (wl : )
& rmRandPSs .~ [farside]
where
fromCond (V2 x _,_) = x < w / 2 - 10
@@ -56,11 +56,9 @@ roomPadCut ps p = defaultRoom
{ _rmPolys = [ps]
, _rmLinks = [(p,0),(V2 0 0,pi)]
, _rmPath = [(V2 0 0,p)]
, _rmPS = []
, _rmBound = []
}
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
plmnts = spanLightI (V2 120 24) (V2 120 216)
: 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]
where
uppers = Node (Left door) [deadRoom topRoom]
botRoom = set rmPS botplmnts $ roomRect 200 200 1 1
topRoom = set rmPS topplmnts $ roomRect 200 200 1 1
botRoom = set rmPmnts botplmnts $ roomRect 200 200 1 1
topRoom = set rmPmnts topplmnts $ roomRect 200 200 1 1
botplmnts =
[sPS (V2 0 0) 0 $ PutWall (rectNSWE 200 0 90 110) defaultCrystalWall
,sPS (V2 50 100) 0 $ PutCrit miniGunCrit
@@ -134,12 +132,12 @@ glassSwitchBack = do
return (V2 crx cry,1.5*pi)
midPS = return (V2 (wth-20) (hgt/2+40), pi)
return $ roomRect wth hgt 2 4
& rmPS .~ plmnts
& rmPmnts .~ plmnts
& rmRandPSs .~ [northPSs,midPS]
glassSwitchBackCrits :: RandomGen g => State g Room
glassSwitchBackCrits = glassSwitchBack
<&> rmPS %~ ([Placement (PSRoomRand 0) (PutCrit miniGunCrit) (const Nothing)
<&> rmPmnts %~ ([Placement (PSRoomRand 0) (PutCrit miniGunCrit) (const Nothing)
, Placement (PSRoomRand 1) randC1 (const Nothing)
] ++)
@@ -178,7 +176,7 @@ miniRoom3 = do
,sPS cp (pi/8+7*pi/4) b
,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 cen p = cen +.+ vNormal (p -.- cen)
@@ -200,7 +198,7 @@ roomMiniIntro = fmap (g . expandTreeBy f) $ sequence $ treeFromPost
roomCenterPillar :: RandomGen g => State g Room
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
plmnts =
[ blockLine (V2 115 115) (V2 115 125)
@@ -216,7 +214,7 @@ roomOctogon = defaultRoom
{ _rmPolys = [poly ]
, _rmLinks = lnks
, _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)] ]
, _rmFloor = [makeTileFromPoly poly 7]
}
@@ -260,7 +258,7 @@ weaponEmptyRoom = do
,mntLightLnkCond (const True)
]
(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 = do
@@ -271,7 +269,7 @@ weaponUnderCrits = do
]
let continuationRoom = treeFromTrunk
[Left corridorN,Left corridorN]
(connectRoom (set rmPS plmnts corridorN))
(connectRoom (set rmPmnts plmnts corridorN))
rcp <- roomCenterPillar
deadEndRoom' <- takeOne [roomPillars,rcp]
junctionRoom <- takeOne [Left tEast,Left tWest]
@@ -292,9 +290,9 @@ weaponBehindPillar = do
rcp <- roomCenterPillar
return $ treeFromTrunk
[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 = do
@@ -307,7 +305,7 @@ weaponBetweenPillars = do
,sPS crPos1 (d crPos1) randC1
,sPS crPos2 (d crPos2) randC1
]
theRoom = roomPillars & rmPS %~ (++ plmnts)
theRoom = roomPillars & rmPmnts %~ (++ plmnts)
(fmap connectRoom . randomiseOutLinks) =<< filterLinks f theRoom
where
f (_,a) = a == 0
@@ -316,7 +314,7 @@ weaponLongCorridor :: RandomGen g => State g (Tree (Either Room Room))
weaponLongCorridor = do
root <- takeOne [tEast, tWest]
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)
i2 <- state $ randomR (2,5)
@@ -324,11 +322,11 @@ weaponLongCorridor = do
let branch2 = treeFromTrunk (replicate i2 $ Left corridorN) (deadRoom $ putWp corridor)
return $ Node (Left root) [branch1,branch2]
where
putCrs = over rmPS (++ [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)]
putCrs = over rmPmnts (++ [sPS (V2 10 40) (-pi/2) randC1 ,sPS (V2 (-10) 40) (-pi/2) randC1 ])
putWp = set rmPmnts [sPS (V2 20 60) 0 $ RandPS randFirstWeapon ,spanLightI (V2 0 40) (V2 40 40)]
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 = defaultRoom
@@ -336,7 +334,7 @@ deadEndRoom = defaultRoom
]
, _rmLinks = lnks
, _rmPath = []
, _rmPS = [sPS (V2 0 (-10)) 0 putLamp]
, _rmPmnts = [sPS (V2 0 (-10)) 0 putLamp]
, _rmBound = [rectNSWE 20 (-20) (-30) 30]
}
where
@@ -353,7 +351,7 @@ weaponRoom = join $ takeOne
roomCCrits :: RandomGen g => State g Room
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 = do
@@ -373,7 +371,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 & rmPS .~ ws ++ brls ++ wsDefense ++
changeLinkTo 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
@@ -385,7 +383,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 & rmPS .~
changeLinkTo 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
@@ -413,19 +411,19 @@ shootersRoom' = do
,spanLightI (V2 (w/2) 200) (V2 (w+10) 200)
]
toPS x y = return (V2 x y,-0.5*pi)
return $ set rmPS plmnts $ roomRectAutoLinks w 600
& rmPS .~ plmnts
return $ set rmPmnts plmnts $ roomRectAutoLinks w 600
& rmPmnts .~ plmnts
& rmRandPSs .~ [toPS x1 y1,toPS x2 y2,toPS x3 y3]
shootersRoom1 :: RandomGen g => State g Room
shootersRoom1 = shootersRoom' <&> rmPS %~
shootersRoom1 = shootersRoom' <&> rmPmnts %~
( (
RandomPlacement $ takeOne $ map (\i -> Placement (PSRoomRand i) (PutCrit autoCrit) (const Nothing))
[0,1,2]
) :)
shootersRoom :: RandomGen g => State g Room
shootersRoom = shootersRoom' <&> rmPS %~
shootersRoom = shootersRoom' <&> rmPmnts %~
( map (\i -> Placement (PSRoomRand i) (PutCrit autoCrit) (const Nothing))
[0,1,2]
++ )
@@ -456,13 +454,13 @@ pillarGrid = do
++
concat [f x y | x<-xs,y<-ys]
return $ roomRect w h (max i 2) (max i 2)
& rmPS .~ plmnts
& rmPmnts .~ plmnts
& rmRandPSs .~ [rps]
-- TODO remove possible identical draws on random PSs
pistolerRoom :: RandomGen g => State g Room
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)
@@ -480,10 +478,10 @@ shootingRange = do
return $ treeFromPost
[Left rm1
,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 $ 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)
@@ -492,6 +490,6 @@ spawnerRoom = do
x <- state $ randomR (250,300)
y <- state $ randomR (300,400)
roomWithSpawner <- roomC x y <&>
rmPS %~ (Placement (PSRoomRand 0) (PutCrit spawnerCrit) (const Nothing) :)
rmPmnts %~ (Placement (PSRoomRand 0) (PutCrit spawnerCrit) (const Nothing) :)
aRoom <- airlock
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 ]
, _rmLinks = lnks
, _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)
$ \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
@@ -48,7 +48,7 @@ airlockSimple = defaultRoom
[ rectNSWE 120 0 0 180 ]
, _rmLinks = lnks
, _rmPath = concatMap (doublePair. (V2 90 30,) . fst) lnks
, _rmPS =
, _rmPmnts =
[ Placement (PS (V2 90 115) pi) (PutButton $ makeSwitch col red id id)
$ \btid -> jspsJ (V2 0 0) 0 (PutDoor col (cond btid) outDoorps)
$ sPS (V2 180 0) 0 (PutDoor col (cond btid) inDoorps)
@@ -77,7 +77,7 @@ airlockZ = defaultRoom
-- [(V2 0 40,V2 40 0)
-- ,(V2 40 0,V2 0 40)
-- ]
, _rmPS =
, _rmPmnts =
[ Placement (PS (V2 90 115) pi) (PutButton $ makeSwitch col red id id)
$ \btid -> jspsJ (V2 0 60) 0 (PutDoor col (cond btid) outDoorps)
$ sPS (V2 180 60) 0 (PutDoor col (cond btid) inDoorps)
@@ -117,7 +117,7 @@ airlock90 = defaultRoom
[(V2 0 40,V2 40 0)
,(V2 40 0,V2 0 40)
]
, _rmPS =
, _rmPmnts =
[ 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
,mountLightV (V2 20 20) (V3 70 70 50)
@@ -145,7 +145,7 @@ airlockCrystal = defaultRoom
]
, _rmLinks = [(V2 20 130,0) ,(V2 20 0 ,pi) ]
, _rmPath = [ ]
, _rmPS =
, _rmPmnts =
[ Placement (PS (V2 145 70) (pi/2)) ( PutButton $ makeSwitch col red id id)
$ \btid -> jsps0 $ PutDoor col (cond btid) pss
, 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+40)), V2 0 x)
]
, _rmPS =
, _rmPmnts =
[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 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 = do
ps <- takeN 5 [V2 x y | x <- [-100,-80 .. 100] ,y <- [-100,-80 .. 100] ]
as <- replicateM 5 . state $ randomR (0,2*pi)
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
cs = (armourChaseCrit & crState . crDropsOnDeath .~ DropSpecific [0])
: replicate 4 chaseCrit
@@ -94,7 +94,7 @@ roomCross x y = defaultRoom
,(V2 (y-20) (-x),pi)
]
, _rmPath = []
, _rmPS =
, _rmPmnts =
[ 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
, _rmLinks = [(V2 (x-1) (y-20),negate $ pi/2)]
, _rmPath = []
, _rmPS = [mountLight (V2 x x) (V3 (x-20) x 70)]
, _rmPmnts = [mountLight (V2 x x) (V3 (x-20) x 70)]
, _rmBound = ps
}
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
, _rmLinks = [(V2 z (y-20), pi/2)]
, _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
}
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]
, _rmLinks = 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 ]
, _rmFloor = [makeTileFromPoly poly 2]
}
@@ -39,7 +39,7 @@ corridorDebug = defaultRoom
]
, _rmLinks = lnks
, _rmPath = concatMap (doublePair . (,) (V2 20 60) . fst) lnks
, _rmPS = []
, _rmPmnts = []
, _rmBound = [ rectNSWE 50 30 0 40 ]
}
where
@@ -55,7 +55,7 @@ corridorN = defaultRoom
]
, _rmLinks = lnks
, _rmPath = pth
, _rmPS = []
, _rmPmnts = []
, _rmBound = [ rectNSWE 50 30 0 40 ]
}
where lnks = [(V2 20 70 ,0)
@@ -70,7 +70,7 @@ tEast = defaultRoom
]
, _rmLinks = lnks
, _rmPath = concatMap (doublePair . (,) (V2 0 60) . fst) lnks
, _rmPS = []
, _rmPmnts = []
, _rmBound = [ rectNSWE 70 10 0 40 ]
}
where
@@ -86,7 +86,7 @@ tWest = defaultRoom
]
, _rmLinks = lnks
, _rmPath = concatMap (doublePair . (,) (V2 0 60) . fst) lnks
, _rmPS = []
, _rmPmnts = []
, _rmBound = [ rectNSWE 70 10 0 40 ]
}
where
src/Dodge/Room/Data.hs
+10 -5
View File
@@ -9,6 +9,7 @@ import Data.Tile
import Control.Monad.State
import System.Random
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.
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
{ _rmPolys :: [ [Point2] ]
, _rmLinks :: [(Point2,Float)]
, _rmUsedLinks :: [(Point2,Float)]
, _rmUsedLinks :: [RoomPos]
, _rmPath :: [(Point2, Point2)]
, _rmPS :: [Placement]
, _rmPmnts :: [Placement]
, _rmLabelledPmnts :: IM.IntMap Placement
, _rmPartialPmnts :: IM.IntMap (Int -> Placement)
, _rmBound :: [ [Point2] ]
, _rmFloor :: [Tile]
, _rmName :: String
@@ -32,7 +35,9 @@ data Room = Room
, _rmRandPSs :: [State StdGen (Point2,Float)]
}
data RoomPos
= Link (Point2,Float)
| UsedLink (Point2,Float)
| LinkInt Int (Point2,Float)
= OutLink Int Point2 Float
| InLink Point2 Float
| PosInt Int Point2 Float
| PosPl Point2 Float
deriving (Eq,Ord,Show)
makeLenses ''Room
src/Dodge/Room/Door.hs
+2 -2
View File
@@ -14,8 +14,8 @@ door = defaultRoom
, _rmLinks = lnks
, _rmPath = [(V2 20 35,V2 20 5)]
-- door extends into side walls (for shadows as rendered 12/03)
, _rmPS = [putAutoDoor (V2 0 20) (V2 40 20)]
, _rmBound = []
, _rmPmnts = [putAutoDoor (V2 0 20) (V2 40 20)]
-- note no bounds
}
where lnks = [(V2 20 35,0)
,(V2 20 5,pi)
src/Dodge/Room/Link.hs
+8
View File
@@ -15,6 +15,7 @@ module Dodge.Room.Link
, randomiseOutLinks
, randomiseLinksBy
, invShiftLinkBy
, setLastLinkToUsed
) where
import Dodge.LevelGen
import Dodge.Room.Data
@@ -105,3 +106,10 @@ shiftPathBy
-> (Point2,Point2)
-> (Point2,Point2)
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)
]
, _rmPath = []
, _rmPS =
, _rmPmnts =
[ 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)
$ 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]
ps <- takeN 4 $ lps ++ rps
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 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)
++ putBlockRect (2*x/3-20) (2*x/3+20) (h/2-20) (h/2+20)
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 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)
++ putBlockRect (2*x/3-20) (2*x/3+20) (h/2-20) (h/2+20)
pillars <- takeOne [pillarsa, pillarsb, pillarsc]
return $ r & rmPS %~ (++ pillars)
return $ r & rmPmnts %~ (++ pillars)
addButtonSlowDoor :: RandomGen g => Float -> Float -> Room -> State g Room
addButtonSlowDoor x h rm = do
@@ -107,7 +107,7 @@ addButtonSlowDoor x h rm = do
]
thePlacement <- takeOne [butDoor butPos butRot ]
changeLinkFrom aboveH =<< changeLinkTo belowH (rm
& rmPS %~ (thePlacement :)
& rmPmnts %~ (thePlacement :)
& rmBound %~ (openDoorBound :)
)
where
@@ -138,7 +138,7 @@ slowDoorRoom = do
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'
proom <- southPillarsRoom x y h
addButtonSlowDoor x h (proom & rmPS %~ (++ (crits ++ barrels ++ lsources)))
addButtonSlowDoor x h (proom & rmPmnts %~ (++ (crits ++ barrels ++ lsources)))
randC1 :: PSType
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 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
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 ]
, _rmLinks = lnks
, _rmPath = concatMap doublePair pth
, _rmPS = []
, _rmPmnts = []
, _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)]
, _rmFloor = [Tile
{ _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. -}
roomRectAutoLinks :: Float -> Float -> Room
roomRectAutoLinks x y = (roomRect x y ((ceiling x - 40) `div` 60) ((ceiling y - 40) `div` 60))
{_rmPS = plmnts}
{_rmPmnts = plmnts}
where
plmnts =
[mntLightLnkCond (const True)
@@ -83,8 +83,8 @@ combineRooms r r' = defaultRoom
, _rmLinks = _rmLinks r ++ _rmLinks r'
, _rmPath = map clampPath $ _rmPath r
++ _rmPath r'
, _rmPS = map (shiftPlacement $ _rmShift r) (_rmPS r)
++ map (shiftPlacement $ _rmShift r') (_rmPS r')
, _rmPmnts = map (shiftPlacement $ _rmShift r) (_rmPmnts r)
++ map (shiftPlacement $ _rmShift r') (_rmPmnts r')
, _rmBound = _rmBound r ++ _rmBound r'
, _rmFloor = _rmFloor r ++ _rmFloor r'
, _rmShift = (V2 0 0 , 0)
@@ -126,7 +126,7 @@ quarterRoomFlat w = do
,(V2 0 (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]]
}
@@ -167,13 +167,13 @@ fourthCornerWall w = do
,(V2 0 0,V2 0 (w-40))
-- ,(V2 (20-w) (w-20),V2 (40-w) (w))
]
, _rmPS = b
, _rmPmnts = b
, _rmBound = [map toV2 [(w,w),(0,2*w),(-w,w)]]
}
{- | Replace the first 'PutNothing' with a given 'PSType'. -}
fillNothingPlacement :: PSType -> Room -> Room
fillNothingPlacement pst r =
r & rmPS %~ replaceNothingWith pst
r & rmPmnts %~ replaceNothingWith pst
where
replaceNothingWith x (Placement (PS p rot) PutNothing _: pss) = sPS p rot 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'. -}
shufflePlacements :: RandomGen g => Room -> State g Room
shufflePlacements r = do
newPSs <- shuffle $ _rmPS r
return $ r & rmPS .~ newPSs
newPSs <- shuffle $ _rmPmnts r
return $ r & rmPmnts .~ newPSs
{- | A randomly generate room based on four randomly generated corners.
Tight corridors, random placements. -}
randomFourCornerRoom :: RandomGen g => State g Room
@@ -201,7 +201,7 @@ randomFourCornerRoom = do
++ replicate 20 chaseCrit
randomiseAllLinks . fillNothingPlacements (crits ++ itms) =<<
( shufflePlacements
. over rmPS ( sps0 putLamp :)
. over rmPmnts ( sps0 putLamp :)
. foldr1 combineRooms
$ 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 )
]
, _rmPath = []
, _rmPS =
, _rmPmnts =
[sps0 $ PutWall (rectNSEW d (d - 30) d (d - 30)) defaultWall
,sps0 $ PutWall (rectNSEW d (d - 30) (-d) (30 - d)) 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 40 (h-40) , V2 20 (h-40) )
]
, _rmPS =
, _rmPmnts =
[ sPS (V2 20 (h-5)) 0 putLamp
, spanLightI (V2 0 (0.4*h)) (V2 40 (0.4*h))
, windowLine (V2 0 (h-20)) (V2 40 (h-20))
@@ -63,7 +63,7 @@ longBlockedCorridor = do
,sPS (V2 20 15) 0 putLamp
]
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.
blockedCorridor :: RandomGen g => State g (Tree (Either Room Room))
@@ -74,14 +74,14 @@ blockedCorridor = do
$ reverse $ rectNSWE 10 (-10) (-10) 10
,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 = defaultRoom
{ _rmPolys = polys
, _rmBound = polys
, _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)
, 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 = 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 = do
@@ -30,7 +30,7 @@ startRoom = do
girderV 40 20 10 (V2 0 (h/2)) (V2 w (h/2))
treeFromPost [Left rezBox, Left door] . Right
<$> randomiseOutLinks (shiftRoomBy (V2 (-20) (-20),0)
$ roomRectAutoLinks w h & rmPS %~
$ roomRectAutoLinks w h & rmPmnts %~
(
[ fground
, 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
w <- 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+ 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)]
, _rmPath = doublePair (V2 0 (-80) , V2 0 (h/2))
, _rmPS =
, _rmPmnts =
[sPS (V2 (15-w) 15 ) 0 $ PutID 0
,sPS (V2 (w-15) 15 ) pi $ PutID 0
,sPS (V2 0 (h-35)) 0 $ PutID 2