{- | Procedural creation of rooms and subroom parts. -} module Dodge.Room.Procedural ( roomRect , roomRectAutoLinks , randomFourCornerRoom , centerVaultRoom , combineRooms , linksAndPath , makeGrid ) where import Dodge.Data import Dodge.Room.Data import Dodge.Room.Placement import Dodge.Room.Link import Dodge.Default.Room import Dodge.Item.Consumable import Dodge.Item.Equipment import Dodge.Item.Weapon import Dodge.RandomHelp import Dodge.LevelGen import Dodge.LevelGen.Data import Dodge.Creature --import Dodge.Default import Geometry import Picture import Data.Tile import Data.List import Data.Function (on) import qualified Data.Tuple.Extra as Tup import qualified Data.Map as M 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 = defaultRoom { _rmPolys = [rectNSWE y 0 0 x ] , _rmLinks = lnks , _rmPath = concatMap doublePair pth , _rmPS = [sPS (V2 (x/2) (y/2)) 0 putLamp] , _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)] , _rmFloor = [Tile { _tilePoly = rectNSWE y 0 0 x , _tileCenter = V2 0 0 , _tileX = V2 50 0 , _tileY = V2 0 50 , _tileZ = 16 } ] } where yd = (y - 40) / fromIntegral yn xd = (x - 40) / fromIntegral xn elnks = zip (translateS (V2 0 20) $ gridPoints 0 1 yd (yn+1)) (repeat ( pi/2)) wlnks = zip (translateS (V2 x 20) $ gridPoints 0 1 yd (yn+1)) (repeat (-pi/2)) nlnks = zip (translateS (V2 20 y) $ gridPoints xd (xn+1) 0 1 ) (repeat 0 ) slnks = zip (translateS (V2 20 0) $ gridPoints xd (xn+1) 0 1 ) (repeat pi ) lnks = nlnks ++ elnks ++ wlnks ++ slnks pth = linksAndPath lnks $ translateS (V2 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 (Tup.both (p +.+)) $ makeRect x y) $ gridPoints x nx y ny gridPoints :: Float -> Int -> Float -> Int -> [Point2] gridPoints x nx y ny = [V2 a b | a <- take nx $ scanl (+) 0 $ repeat x , b <- take ny $ scanl (+) 0 $ repeat y ] makeRect :: Float -> Float -> [(Point2,Point2)] makeRect x y = map (bimap toV2 toV2) [((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, minimumBy (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' = defaultRoom { _rmPolys = _rmPolys r ++ _rmPolys r' , _rmLinks = _rmLinks r ++ _rmLinks r' , _rmPath = _rmPath r ++ _rmPath r' , _rmPS = _rmPS r ++ _rmPS r' , _rmBound = _rmBound r ++ _rmBound r' , _rmFloor = _rmFloor r ++ _rmFloor 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 = -- [sPS (0,w/2) 0 putLamp -- ] -- , _rmBound = [[(0,0),(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 [ [ sPS (V2 (20-w) (w-40)) 0 putLamp , sPS (V2 0 40) 0 putLamp , sPS (V2 (w-20) (w-20)) pi PutNothing , blockLine (V2 (w/2) (w/2)) (V2 (w/2) w) ] , [ sPS (V2 (20-w) (w-40)) 0 putLamp , sPS (V2 0 40) 0 putLamp , sPS (V2 (w-20) (w-20)) pi PutNothing , blockLine (V2 (w/2) (w/2)) (V2 (negate $ w/2) (w/2)) ] , [ sPS (V2 (20-w) (w-40)) 0 putLamp , sPS (V2 0 20) 0 putLamp , sPS (V2 (w-20) (w-20)) pi PutNothing , blockLine (V2 (w/2) (w/2)) (V2 0 (w/2)) , blockLine (V2 (-29) w) (V2 0 (w/2)) ] ] pure $ defaultRoom { _rmPolys = [ map toV2 [(0,0),(w,w),(-w,w)] ] , _rmLinks = [(V2 0 w, 0)] , _rmPath = [(V2 0 w,V2 0 0),(V2 0 0,V2 0 w)] , _rmPS = b , _rmBound = [[V2 0 0,V2 w w,V2 (-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 = [sPS (0,w) 0 putLamp] -- , _rmBound = [[(w,w),(0,2*w),(-w,w)]] -- } fourthCornerWall :: RandomGen g => Float -> State g Room fourthCornerWall w = do b <- takeOne [ [ sPS (V2 (10-w) w) 0 putLamp , sPS (V2 (w-10) w) 0 putLamp , sPS (V2 0 10) 0 putLamp , sPS (V2 0 (2*w-20)) pi PutNothing , blockLine (V2 (w/2) (w/2)) (V2 0 w) , blockLine (V2 (negate $ w/2) (w/2)) (V2 0 w) ] , [ sPS (V2 0 (3*w/2)) 0 putLamp , sPS (V2 (w-10) w) 0 putLamp , sPS (V2 (10-w) (w-20) ) 0 putLamp , sPS (V2 0 10 ) 0 putLamp , sPS (V2 0 (2*w-20)) pi PutNothing , blockLine (V2 (w/2) (w/2)) (V2 0 w) , blockLine (V2 (negate w) w ) (V2 0 w) ] , [ sPS (V2 (10-w) w ) 0 putLamp , sPS (V2 (w-10) w ) 0 putLamp , sPS (V2 0 10 ) 0 putLamp , sPS (V2 20 (2*w-40)) pi PutNothing , blockLine (V2 (w/2) (w/2)) (V2 0 w) , blockLine (V2 0 w) (V2 0 (w*2)) ] ] pure $ defaultRoom { _rmPolys = [ map toV2 [(0,0),(w,w),(0,2*w),(-w,w)] ] , _rmLinks = [(V2 (w/2) (3*w/2), negate $ pi/4) ,(V2 (negate $ w/2) (3*w/2), pi/4) ] , _rmPath = [(V2 0 w,V2 0 0),(V2 0 0,V2 0 w)] , _rmPS = 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 where replaceNothingWith x (SinglePlacement (PS p rot PutNothing): pss) = sPS p rot x : pss replaceNothingWith x (ps:pss) = ps : replaceNothingWith x pss replaceNothingWith _ [] = [] {- | Successively fill 'PutNothing' placements with a list of given 'PSType's. -} fillNothingPlacements :: [PSType] -> Room -> Room fillNothingPlacements pst r = foldr fillNothingPlacement r pst {- | 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 r = do newPSs <- shuffle $ _rmPS r return $ r & rmPS .~ newPSs {- | A randomly generate room based on four randomly generated corners. Tight corridors, random placements. -} randomFourCornerRoom :: RandomGen g => State g Room randomFourCornerRoom = do corners <- replicateM 4 . join $ takeOne [fourthWall 100, fourthCornerWall 100] nItms <- state $ randomR (1,2) itms <- takeN nItms $ fmap PutFlIt $ [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 . fillNothingPlacements (crits ++ itms) =<< ( shufflePlacements . foldr1 combineRooms $ zipWith (\r a -> shiftRoomBy (V2 0 0,a) r) corners [0,pi/2,pi,3*pi/2] ) {- | Creates room with a central vault with doors around it. -} centerVaultRoom :: Int -- ^ Door id -> Float -- ^ Width -> Float -- ^ Height -> Float -- ^ Vault dimensions -> State g Room centerVaultRoom n w h d = do let northPoly = rectNSWE h d (-w) w nsDoors = rectNSWE (d + 20) (negate (d +20)) (-20) 20 weDoors = rectNSWE 20 (-20) (d + 20) (negate (d +20)) centerPoly = rectWdthHght (d - 20) (d - 20) polys = centerPoly : nsDoors : weDoors : take 4 (iterate (map vNormal) northPoly) return $ defaultRoom { _rmPolys = polys , _rmLinks = [(V2 0 h , 0 ) ,(V2 w 0 ,-pi/2) ,(V2 (-w) 0 , pi/2) ,(V2 0 (-h), pi ) ] , _rmPath = [] , _rmPS = [sPS (V2 (d-25) (d-25)) 0 putLamp ,sPS (V2 (w-5) (h-5)) 0 putLamp ,sPS (V2 (w-5) (5-h)) 0 putLamp ,sPS (V2 (5-w) (h-5)) 0 putLamp ,sPS (V2 (5-w) (5-h)) 0 putLamp ] ++ concat (zipWith (\i r -> map (shiftPSBy (V2 0 0,r)) $ theDoor i) [n, n+1, n+2, n+3] [0,pi/2,pi,3*pi/2]) , _rmBound = [rectNSWE h (-h) (-w) w] } where col = dim $ dim $ bright red theDoor i = [ sPS (V2 0 (d-10)) 0 $ PutDoubleDoor col (cond i) (V2 (-19) 0) (V2 19 0) , sPS (V2 35 (d+4)) 0 $ PutButton $ makeSwitch col (over worldState (M.insert (DoorNumOpen i) True)) (over worldState (M.insert (DoorNumOpen i) False)) ] cond i w' = or $ M.lookup (DoorNumOpen i) (_worldState w')