{- 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] )