262 lines
10 KiB
Haskell
262 lines
10 KiB
Haskell
{- |
|
|
Procedural creation of rooms and subroom parts. -}
|
|
module Dodge.Room.Procedural
|
|
( roomRect
|
|
, roomRectAutoLinks
|
|
, randomFourCornerRoom
|
|
, randomFourCornerRoomCrsIts
|
|
, centerVaultRoom
|
|
, combineRooms
|
|
, linksAndPath
|
|
, makeGrid
|
|
) where
|
|
import Dodge.Data
|
|
import Dodge.Placement.Shift
|
|
import Dodge.Default.Wall
|
|
--import Shape.Data
|
|
import Dodge.PlacementSpot
|
|
import Dodge.Placement.Instance
|
|
import Dodge.RoomLink
|
|
--import Dodge.Item.Weapon.Utility
|
|
import Dodge.Room.Link
|
|
import Dodge.Room.Path
|
|
import Dodge.Default.Room
|
|
--import Dodge.Item.Consumable
|
|
--import Dodge.Item.Equipment
|
|
import Dodge.Room.Foreground
|
|
--import Dodge.Item.Weapon
|
|
import Dodge.RandomHelp
|
|
import Dodge.LevelGen.Data
|
|
import Dodge.LevelGen.Switch
|
|
import Dodge.Creature
|
|
import Geometry
|
|
import Picture
|
|
import Data.Tile
|
|
import LensHelp
|
|
|
|
import qualified Data.Set as S
|
|
import qualified Data.IntMap.Strict as IM
|
|
--import Control.Lens
|
|
import Control.Monad
|
|
import Control.Monad.State
|
|
import System.Random
|
|
-- This will need a cleanup, but it might change a bit first
|
|
{- A simple rectangular room with a light in the center.
|
|
Creates links and pathfinding graph. -}
|
|
roomRect
|
|
:: Float -- ^ Width
|
|
-> Float -- ^ Height
|
|
-> Int -- ^ Number of links on vertical walls
|
|
-> Int -- ^ Number of links on horizontal walls
|
|
-> Room
|
|
roomRect x y xn yn = defaultRoom
|
|
{ _rmPolys = [rectNSWE y 0 0 x ]
|
|
, _rmLinks = lnks
|
|
, _rmPath = concatMap doublePair pth
|
|
, _rmPos = map (roomposat RoomPosOnPath) posps
|
|
++ map (roomposat RoomPosOffPath) interposps
|
|
, _rmPmnts = []
|
|
, _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)]
|
|
, _rmFloor = Tiled [Tile
|
|
{ _tilePoly = rectNSWE y 0 0 x
|
|
, _tileZero = V2 0 0
|
|
, _tileX = V2 1 0
|
|
, _tileZ = 16
|
|
} ]
|
|
, _rmRandPSs = [psRandRanges (10,x-10) (10,y-10) (0,2*pi)]
|
|
}
|
|
where
|
|
roomposat onoffpath p = RoomPos p 0 (S.singleton onoffpath) NotLink 0
|
|
yd = (y - 40) / fromIntegral yn
|
|
xd = (x - 40) / fromIntegral xn
|
|
somelnks poffset ps a = zip (map (+.+ poffset) ps) (repeat a)
|
|
elnks = somelnks (V2 0 20) (gridPoints 0 1 yd (yn+1)) ( pi/2)
|
|
wlnks = somelnks (V2 x 20) (gridPoints 0 1 yd (yn+1)) (-pi/2)
|
|
nlnks = somelnks (V2 20 y) (gridPoints xd (xn+1) 0 1 ) 0
|
|
slnks = somelnks (V2 20 0) (gridPoints xd (xn+1) 0 1 ) pi
|
|
lnks = m North FromWest nlnks
|
|
++ m East FromSouth elnks
|
|
++ m West FromSouth wlnks
|
|
++ m South FromWest slnks
|
|
m edge edgefrom = zipWith (lnkBothAnd' (OnEdge edge) edgefrom) [0..]
|
|
pth = linksAndPath' lnks $ map (bimap (+.+ V2 20 20) (+.+ V2 20 20)) (makeGrid xd xn yd yn)
|
|
posps = map (+.+ V2 20 20) $ gridPoints xd (xn+1) yd (yn+1)
|
|
interposps = map (+.+ V2 (20 + xd/2) (20 + yd/2)) $ gridPoints xd xn yd yn
|
|
{- Creates a rectangular room, automatically creates links and pathfinding graph at a sensible size. -}
|
|
-- it is not clear to me that this works for very small rooms (but it does seem
|
|
-- to do so)
|
|
roomRectAutoLinks :: Float -> Float -> Room
|
|
roomRectAutoLinks x y = (roomRect x y xn yn)
|
|
{_rmPmnts = plmnts}
|
|
where
|
|
xn = max 1 $ (ceiling x - 40) `div` 60
|
|
yn = max 1 $ (ceiling y - 40) `div` 60
|
|
plmnts = replicate 3 (mntLightLnkCond $ useRoomPosCond isUsedLnkUnplaced)
|
|
{- Combines two rooms into one room.
|
|
- will have to work out exactly what to do with combining links
|
|
Mostly involves concatenation. -}
|
|
combineRooms :: Room -> Room -> Room
|
|
combineRooms r r' = defaultRoom
|
|
{ _rmPolys = _rmPolys r ++ _rmPolys r'
|
|
, _rmLinks = _rmLinks r ++ _rmLinks r'
|
|
, _rmPath = map clampPath $ _rmPath r
|
|
++ _rmPath r'
|
|
, _rmPmnts = _rmPmnts r ++ _rmPmnts r'
|
|
--, _rmPmnts = map (shiftPlacement $ _rmShift r) (_rmPmnts r)
|
|
-- ++ map (shiftPlacement $ _rmShift r') (_rmPmnts r')
|
|
, _rmBound = _rmBound r ++ _rmBound r'
|
|
, _rmPos = _rmPos r ++ _rmPos r'
|
|
, _rmFloor = combineFloors (_rmFloor r) (_rmFloor r')
|
|
, _rmShift = (V2 0 0 , 0)
|
|
}
|
|
-- not that this assumes that any link paths are integral
|
|
clampPath :: (Point2,Point2) -> (Point2, Point2)
|
|
clampPath = bimap f f
|
|
where
|
|
f (V2 x y) = V2 (g x) (g y)
|
|
g = (fromIntegral :: Int -> Float) . floor
|
|
|
|
combineFloors :: Floor -> Floor -> Floor
|
|
combineFloors f _ = f
|
|
{- Randomly generate a top fourth of a room possibly with a wall.
|
|
Add a light and a 'PutNothing' placement. -}
|
|
quarterRoomTri :: RandomGen g => Float -> State g Room
|
|
quarterRoomTri w = do
|
|
b <- takeOne
|
|
[ [ mntLS vShape (V2 0 w) (V3 0 (w-20) 70)
|
|
, blockLine (V2 (w/2) (w/2)) (V2 (w/2) w)
|
|
]
|
|
, [blockLine (V2 (w/2) (w/2)) (V2 (negate $ w/2) (w/2))]
|
|
, [ blockLine (V2 (w/2) (w/2)) (V2 0 (w/2))
|
|
, blockLine (V2 (-29) w) (V2 0 (w/2))
|
|
]
|
|
]
|
|
pure $ defaultRoom
|
|
{ _rmPolys = [ [V2 0 0,V2 w w,V2 (-w) w] ]
|
|
, _rmLinks = [toBothLnk (V2 0 w, 0)]
|
|
, _rmPath = concatMap doublePair
|
|
[(V2 0 w,V2 0 (w-20))
|
|
,(V2 0 (w-20),V2 (w-20) (w-20))
|
|
,(V2 0 (w-20),V2 (55-w) (w-20))
|
|
,(V2 (55-w) (w-20),V2 (20-w) (w-20))
|
|
,(V2 0 (w-20),V2 0 0)
|
|
,(V2 (55-w) (w-20),V2 0 0)
|
|
]
|
|
, _rmPmnts = b ++ [ mntLS iShape (V2 (w-20) w) (V3 (w-20) (w-20) 70)
|
|
, sPS (V2 (w-20) (w-20)) pi PutNothing
|
|
, sPS (V2 (w-15) (w-25)) pi PutNothing
|
|
]
|
|
, _rmPos =
|
|
[ RoomPos (V2 (w-20) (w-20)) pi S.empty NotLink 0
|
|
, RoomPos (V2 (w-15) (w-25)) pi S.empty NotLink 0
|
|
]
|
|
, _rmBound = [[V2 0 0,V2 w w,V2 (-w) w]]
|
|
}
|
|
quarterRoomSquare :: RandomGen g => Float -> State g Room
|
|
quarterRoomSquare w = do
|
|
b <- takeOne
|
|
[ [ mntLS vShape (V2 0 (2*w-20)) (V3 0 (2*w-40) 70)
|
|
, blockLine (V2 (negate $ w/2) (w/2)) (V2 0 w)
|
|
]
|
|
, [ mntLS vShape (V2 0 (2*w-20)) (V3 0 (2*w-40) 70)
|
|
, blockLine (V2 (negate w) w ) (V2 0 w)
|
|
]
|
|
, [ mntLS iShape (V2 (0.7*w) (1.3*w)) (V3 (0.7*w-20) (1.3*w-20) 70)
|
|
, blockLine (V2 0 w) (V2 0 (w*2))
|
|
]
|
|
]
|
|
pure $ defaultRoom
|
|
{ _rmPolys = [ map toV2 [(0,0),(w,w),(0,2*w),(-w,w)] ]
|
|
, _rmLinks =
|
|
[toBothLnk (V2 (w/2) (3*w/2), negate $ pi/4)
|
|
,toBothLnk (V2 (negate $ w/2) (3*w/2), pi/4)
|
|
]
|
|
, _rmPath = concatMap doublePair
|
|
[(V2 (0.5*w) (1.5*w),V2 (0.5*w-20) (1.5*w-20))
|
|
,(V2 (-0.5*w) (1.5*w),V2 (-0.5*w+20) (1.5*w-20))
|
|
,(V2 0 (2*w-40),V2 (-0.5*w+20) (1.5*w-20))
|
|
,(V2 0 (2*w-40),V2 (0.5*w-20) (1.5*w-20))
|
|
,(V2 (w-20) (w-20),V2 (0.5*w-20) (1.5*w-20))
|
|
,(V2 (20-w) (w-20),V2 (-0.5*w+20) (1.5*w-20))
|
|
--,(V2 (40-w) (w),V2 0 (w-40))
|
|
,(V2 (20-w) (w-20),V2 0 (w-40))
|
|
,(V2 0 0,V2 0 (w-40))
|
|
-- ,(V2 (20-w) (w-20),V2 (40-w) (w))
|
|
]
|
|
, _rmPmnts = b ++
|
|
[ 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
|
|
]
|
|
, _rmPos =
|
|
[ RoomPos (V2 20 (2*w-40)) pi S.empty NotLink 0
|
|
, RoomPos (V2 25 (2*w-45)) pi S.empty NotLink 0
|
|
]
|
|
, _rmBound = [map toV2 [(w,w),(0,2*w),(-w,w)]]
|
|
}
|
|
{- | Randomise the ordering of placements in a room.
|
|
Useful for randomising the position of generic placements such as 'PutNothing'. -}
|
|
shufflePlacements :: RandomGen g => Room -> State g Room
|
|
shufflePlacements = rmPmnts shuffle
|
|
--shufflePlacements r = do
|
|
-- newPSs <- shuffle $ _rmPmnts r
|
|
-- return $ r & rmPmnts .~ newPSs
|
|
{- | A randomly generate room based on four randomly generated corners.
|
|
Tight corridors, random placements. -}
|
|
randomFourCornerRoom :: RandomGen g => [Item] -> State g Room
|
|
randomFourCornerRoom its = do
|
|
nCrits <- state $ randomR (1,3)
|
|
crits <- takeN nCrits <=< shuffle $ [spreadGunCrit,pistolCrit,autoCrit,armourChaseCrit]
|
|
++ replicate 20 chaseCrit
|
|
randomFourCornerRoomCrsIts crits its
|
|
{- | A randomly generate room based on four randomly generated corners.
|
|
Tight corridors. -}
|
|
randomFourCornerRoomCrsIts :: RandomGen g => [Creature] -> [Item] -> State g Room
|
|
randomFourCornerRoomCrsIts crits its = do
|
|
corners <- replicateM 4 . join $ takeOne [quarterRoomTri 100, quarterRoomSquare 100]
|
|
itms <- shuffle its
|
|
let putitms = map (\it -> sps0 (PutFlIt it) & plSpot .~ anyUnusedSpot) itms
|
|
putcrits = map (\cr -> sps0 (PutCrit cr) & plSpot .~ unusedSpotAwayFromLink 50) crits
|
|
randomiseAllLinks . (rmPmnts .++~ (putitms ++ putcrits)) =<<
|
|
( shufflePlacements
|
|
. over rmPmnts ( sps0 putLamp :)
|
|
. foldr1 combineRooms
|
|
$ zipWith (\r a -> moveRoomBy (V2 0 0,a) r) corners [0,pi/2,pi,3*pi/2]
|
|
)
|
|
{- | Creates room with a central vault with doors around it. -}
|
|
centerVaultRoom
|
|
:: Float -- ^ Width
|
|
-> Float -- ^ Height
|
|
-> Float -- ^ Vault dimensions
|
|
-> State g Room
|
|
centerVaultRoom w h d = do
|
|
return $ defaultRoom
|
|
{ _rmPolys = [rectNSWE h (-h) (-w) w]
|
|
, _rmLinks =
|
|
[outLink (V2 0 h) 0
|
|
,outLink (V2 w 0) (-pi/2)
|
|
,outLink (V2 (-w) 0) (pi/2)
|
|
, inLink (V2 0 (-h)) pi ]
|
|
, _rmPath = []
|
|
, _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
|
|
,sps0 $ PutWall (rectNSEW (-d) (30 - d) (-d) (30 - d)) defaultWall
|
|
,sps0 $ PutShape $ girder 70 10 10 (V2 (d-11) (-d)) (V2 (d-11) (-h))
|
|
]
|
|
++ map (\a -> mntLS vShape (rotateV a $ V2 0 d) (rotate3z a $ V3 0 (d+30) 70))
|
|
[0,0.5*pi,pi,1.5*pi]
|
|
++ concatMap (\r -> map (shiftPlacement (V2 0 0,r)) theDoor)
|
|
[0,pi/2,pi,3*pi/2]
|
|
, _rmBound = [rectNSWE h (-h) (-w) w]
|
|
}
|
|
where
|
|
col = dim $ dim $ bright red
|
|
theDoor =
|
|
[ pContID (PS (V2 35 (d+4)) 0) (PutButton $ makeSwitch col red id id)
|
|
$ \btid -> jspsJ (V2 0 (d-10)) 0 (PutSlideDr False col (cond' btid) 1 (V2 (-21) 0) (V2 0 0) 2)
|
|
$ sPS (V2 0 (d-10)) 0 (PutSlideDr False col (cond' btid) 1 (V2 21 0) (V2 0 0) 2)
|
|
]
|
|
cond' btid w' = _btState (_buttons w' IM.! btid) == BtOn
|