232 lines
7.6 KiB
Haskell
232 lines
7.6 KiB
Haskell
{-
|
|
Procedural creation of rooms.
|
|
-}
|
|
module Dodge.Room.Procedural
|
|
( roomRect
|
|
, roomRectAutoLinks
|
|
, testRoom
|
|
) where
|
|
import Dodge.Data
|
|
import Dodge.Room.Data
|
|
import Dodge.Room.Placement
|
|
import Dodge.Room.Link
|
|
import Dodge.Item.Consumable
|
|
import Dodge.Item.Weapon
|
|
import Dodge.RandomHelp
|
|
import Dodge.LevelGen
|
|
import Dodge.LevelGen.Data
|
|
import Dodge.Creature
|
|
import Dodge.Default
|
|
import Geometry
|
|
|
|
import Data.List (nub,nubBy,sortBy)
|
|
import Data.Function (on)
|
|
import Control.Lens
|
|
import Control.Monad
|
|
import Control.Monad.State
|
|
import System.Random
|
|
{-
|
|
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 = Room
|
|
{ _rmPolys = [rectNSWE y 0 0 x ]
|
|
, _rmLinks = lnks
|
|
, _rmPath = concatMap doublePair pth
|
|
, _rmPS = [PS (x/2,y/2) 0 $ putLamp]
|
|
, _rmBound = rectNSWE (y+5) (-5) (-5) (x+5)
|
|
}
|
|
where
|
|
yd = (y - 40) / fromIntegral yn
|
|
xd = (x - 40) / fromIntegral xn
|
|
elnks = flip zip (repeat ( pi/2)) $ translateS (0,20) $ gridPoints 0 1 yd (yn+1)
|
|
wlnks = flip zip (repeat (-pi/2)) $ translateS (x,20) $ gridPoints 0 1 yd (yn+1)
|
|
nlnks = flip zip (repeat ( 0)) $ translateS (20,y) $ gridPoints xd (xn+1) 0 1
|
|
slnks = flip zip (repeat ( pi)) $ translateS (20,0) $ gridPoints xd (xn+1) 0 1
|
|
lnks = nlnks ++ elnks ++ wlnks ++ slnks
|
|
pth = linksAndPath lnks $ translateS (20,20) (makeGrid xd xn yd yn)
|
|
{-
|
|
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)
|
|
|
|
makeGrid :: Float -> Int -> Float -> Int -> [(Point2,Point2)]
|
|
makeGrid x nx y ny = nub $ concatMap doublePair
|
|
$ concatMap (\p -> map (\(a,b) -> (p +.+ a,p +.+ b)) $ makeRect x y)
|
|
$ gridPoints x nx y ny
|
|
|
|
gridPoints :: Float -> Int -> Float -> Int -> [Point2]
|
|
gridPoints x nx y ny = [(a,b) | a <- take nx $ scanl (+) 0 $ repeat x
|
|
, b <- take ny $ scanl (+) 0 $ repeat y
|
|
]
|
|
|
|
makeRect :: Float -> Float -> [(Point2,Point2)]
|
|
makeRect x y = [((0,0),(x,0))
|
|
,((0,0),(0,y))
|
|
,((x,y),(x,0))
|
|
,((x,y),(0,y))
|
|
]
|
|
|
|
linksAndPath :: [(Point2,Float)] -> [(Point2,Point2)] -> [(Point2,Point2)]
|
|
linksAndPath lnks subpth = subpth ++ concatMap linkClosest lnks
|
|
where linkClosest (p,_) = doublePair (p, head $ sortBy (compare `on` dist p) $ map fst subpth)
|
|
|
|
{- Combines two rooms into one room.
|
|
Combines into one big bound, concatenates the rest.
|
|
-}
|
|
combineRooms :: Room -> Room -> Room
|
|
combineRooms r r' = Room
|
|
{ _rmPolys = _rmPolys r ++ _rmPolys r'
|
|
, _rmLinks = _rmLinks r ++ _rmLinks r'
|
|
, _rmPath = _rmPath r ++ _rmPath r'
|
|
, _rmPS = _rmPS r ++ _rmPS r'
|
|
, _rmBound = convexHull . nubBy (\a b -> dist a b < 5) $ _rmBound r ++ _rmBound r'
|
|
}
|
|
|
|
{-
|
|
The top fourth of a room of a given height.
|
|
-}
|
|
fourth
|
|
:: Float -- ^ Distance from center of room to top edge
|
|
-> Room
|
|
fourth w = Room
|
|
{ _rmPolys = [ [(0,0),(w,w),(-w,w)] ]
|
|
, _rmLinks = [((0,w), 0)]
|
|
, _rmPath = [((0,w),(0,0)),((0,0),(0,w))]
|
|
, _rmPS =
|
|
[PS (0,w/2) 0 putLamp
|
|
]
|
|
, _rmBound = [(w,w),(-w,w)]
|
|
}
|
|
|
|
{-
|
|
Randomly generate a top fourth of a room possibly with a wall.
|
|
Add a light and a 'PutNothing' placement.
|
|
-}
|
|
fourthWall :: RandomGen g => Float -> State g Room
|
|
fourthWall w = do
|
|
b <- takeOne
|
|
--[ [ PS (20-w,w-40) 0 putLamp
|
|
-- , PS (w-20,w-40) pi PutNothing
|
|
-- ]
|
|
-- [ [ PS (20-w,w-40) 0 putLamp
|
|
-- , PS (0,40) 0 putLamp
|
|
-- , PS (w-20,w-40) pi PutNothing
|
|
-- , blockLine (w/2,w) (negate $ w/2,w/2)
|
|
-- ]
|
|
[ [ PS (20-w,w-40) 0 putLamp
|
|
, PS (0,40) 0 putLamp
|
|
, PS (w-20,w-20) pi PutNothing
|
|
, blockLine (w/2,w/2) (w/2,w)
|
|
]
|
|
, [ PS (20-w,w-40) 0 putLamp
|
|
, PS (0,40) 0 putLamp
|
|
, PS (w-20,w-20) pi PutNothing
|
|
, blockLine (w/2,w/2) (negate $ w/2,w/2)
|
|
]
|
|
, [ PS (20-w,w-40) 0 putLamp
|
|
, PS (0,20) 0 putLamp
|
|
, PS (w-20,w-20) pi PutNothing
|
|
, blockLine (w/2,w/2) (0,w/2)
|
|
, blockLine (-29,w) (0,w/2)
|
|
]
|
|
]
|
|
pure $ Room
|
|
{ _rmPolys = [ [(0,0),(w,w),(-w,w)] ]
|
|
, _rmLinks = [((0,w), 0)]
|
|
, _rmPath = [((0,w),(0,0)),((0,0),(0,w))]
|
|
, _rmPS = b
|
|
, _rmBound = [(w,w),(-w,w)]
|
|
}
|
|
|
|
fourthCorner :: Float -> Room
|
|
fourthCorner w = Room
|
|
{ _rmPolys = [ [(0,0),(w,w),(0,2*w),(-w,w)] ]
|
|
, _rmLinks =
|
|
[((w/2,3*w/2), negate $ pi/4)
|
|
,((negate $ w/2,3*w/2), pi/4)
|
|
]
|
|
, _rmPath = [((0,w),(0,0)),((0,0),(0,w))]
|
|
, _rmPS = [PS (0,w) 0 putLamp]
|
|
, _rmBound = [(w,w),(0,2*w),(-w,w)]
|
|
}
|
|
|
|
fourthCornerWall :: RandomGen g => Float -> State g Room
|
|
fourthCornerWall w = do
|
|
b <- takeOne
|
|
[ [ PS (10-w,w) 0 putLamp
|
|
, PS (w-10,w) 0 putLamp
|
|
, PS (0,10) 0 putLamp
|
|
, PS (0,2*w-20) pi PutNothing
|
|
, blockLine (w/2,w/2) (0,w)
|
|
, blockLine (negate $ w/2,w/2) (0,w)
|
|
]
|
|
, [ PS (0,3*w/2) 0 putLamp
|
|
, PS (w-10,w) 0 putLamp
|
|
, PS (10-w,w-20) 0 putLamp
|
|
, PS (0,10) 0 putLamp
|
|
, PS (0,2*w-20) pi PutNothing
|
|
, blockLine (w/2,w/2) (0,w)
|
|
, blockLine (negate $ w,w) (0,w)
|
|
]
|
|
, [ PS (10-w,w) 0 putLamp
|
|
, PS (w-10,w) 0 putLamp
|
|
, PS (0,10) 0 putLamp
|
|
, PS (20,2*w-40) pi PutNothing
|
|
, blockLine (w/2,w/2) (0,w)
|
|
, blockLine (0,w) (0,w*2)
|
|
]
|
|
]
|
|
pure $ Room
|
|
{ _rmPolys = [ [(0,0),(w,w),(0,2*w),(-w,w)] ]
|
|
, _rmLinks =
|
|
[((w/2,3*w/2), negate $ pi/4)
|
|
,((negate $ w/2,3*w/2), pi/4)
|
|
]
|
|
, _rmPath = [((0,w),(0,0)),((0,0),(0,w))]
|
|
, _rmPS = b
|
|
, _rmBound = [(w,w),(0,2*w),(-w,w)]
|
|
}
|
|
|
|
fillNothingPlacement :: PSType -> Room -> Room
|
|
fillNothingPlacement pst r =
|
|
r & rmPS %~ replaceNothingWith pst
|
|
where
|
|
replaceNothingWith x (PS p rot PutNothing: pss) = PS p rot x : pss
|
|
replaceNothingWith x (ps:pss) = ps : replaceNothingWith x pss
|
|
replaceNothingWith _ [] = []
|
|
|
|
fillNothingPlacements :: [PSType] -> Room -> Room
|
|
fillNothingPlacements pst r = foldr fillNothingPlacement r pst
|
|
|
|
shufflePlacements :: RandomGen g => Room -> State g Room
|
|
shufflePlacements r = do
|
|
newPSs <- shuffle $ _rmPS r
|
|
return $ r & rmPS .~ newPSs
|
|
|
|
putDefaultFlIt :: Item -> PSType
|
|
putDefaultFlIt itm = PutFlIt $ defaultFlIt { _flItRot = 0, _flIt = itm }
|
|
|
|
testRoom :: RandomGen g => State g Room
|
|
testRoom = do
|
|
corners <- replicateM 4 . join $ takeOne [fourthWall 100, fourthCornerWall 100]
|
|
nItms <- state $ randomR (1,2)
|
|
itms <- takeN nItms $ fmap putDefaultFlIt $ [autoRadar,autoSonar,remoteLauncher,jetPack,blinkGun] ++ replicate 5 (medkit 500)
|
|
nCrits <- state $ randomR (1,3)
|
|
crits <- takeN nCrits $ fmap PutCrit $ [spreadGunCrit,pistolCrit,autoCrit,armourChaseCrit]
|
|
++ replicate 20 chaseCrit
|
|
randomiseAllLinks =<<
|
|
( fmap (fillNothingPlacements $ crits ++ itms)
|
|
. shufflePlacements
|
|
. foldr1 combineRooms
|
|
$ zipWith (\r a -> shiftRoomBy ((0,0),a) r) corners [0,pi/2,pi,3*pi/2]
|
|
)
|
|
|