diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 884dba5f4..185588b16 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -1,3 +1,5 @@ +{- | +The tree of rooms that make up a level. -} module Dodge.Floor ( levx ) where @@ -33,17 +35,19 @@ import Control.Lens import Control.Monad.State import Control.Monad.Loops import System.Random - +{- | +A test level tree. -} roomTreex :: RandomGen g => State g (Maybe [Room]) roomTreex = do struct' <- aTreeStrut -- let struct = treeFromPost [[SpecificRoom $ fmap (pure . Right) pistolerRoom]] [EndRoom] - let struct = treeFromPost [[Corridor,SpecificRoom $ fmap (pure . Right) testRoom]] [EndRoom] + let struct = treeFromPost [[Corridor,SpecificRoom $ fmap (pure . Right) randomFourCornerRoom]] [EndRoom] let t' = padCorridors struct t = treeFromTrunk [[StartRoom] ,[Corridor] - ,[SpecificRoom $ (pure . pure . Right) $ airlockCrystal 20] + ,[BossAno $ addArmour launcherCrit & crHP +~ 800 + & crState . crDropsOnDeath .~ DropSpecific [0] ] ,[Corridor] ,[DoorAno] ,[SpecificRoom $ fmap (pure . Right) @@ -55,7 +59,7 @@ roomTreex = do ] ,[FirstWeapon] ,[Corridor] - ,[SpecificRoom $ fmap (pure . Right) testRoom] + ,[SpecificRoom $ fmap (pure . Right) randomFourCornerRoom] ,[Corridor] ,[OrAno [[SpecificRoom $ branchRectWith $ fmap (pure . Left) armouredChasers] @@ -74,51 +78,3 @@ roomTreex = do levx :: RandomGen g => State g [Room] levx = untilJust roomTreex -lev1' :: RandomGen g => State g (Tree Room) -lev1' = do - firstWeapon <- takeOne $ [[branchRectWith weaponRoom,longBlockedCorridor]] ++ replicate 5 [weaponRoom] - iterateWhile boundClip $ fmap (shiftRoomTree . expandTreeBy id) - $ sequence $ treeFromPost - ( - [return $ return $ Right deadEndRoom - ] - ++ [return $ connectRoom corridor - ,return $ connectRoom door - ,glassSwitchBack >>= (fmap connectRoom . randomiseOutLinks)] - ++ [return $ connectRoom corridor - ,return $ connectRoom door] - ++ [miniRoom3] - ++ [return $ connectRoom corridor - ,return $ connectRoom door] - ++ [roomCCrits] - ++ [return $ connectRoom corridor - ,return $ connectRoom door] - ++[roomMiniIntro] - ++ [longRoom >>= (fmap connectRoom . randomiseOutLinks)] - ++ [return $ connectRoom corridor - ,return $ connectRoom door] - ++ firstWeapon - ++ [return $ connectRoom corridor - ,return $ connectRoom door] - ++ [(fmap connectRoom . randomiseOutLinks) =<< pistolerRoom] - ++ [return $ connectRoom door] - ++ [(fmap connectRoom . randomiseOutLinks) =<< shooterRoom] - ++ (replicate 3 $ (fmap connectRoom . randomiseOutLinks) corridor) - ++ [return $ connectRoom (set rmPS [PS (20,40) 0 basicLS] corridor)] - ++ [return $ connectRoom corridor] - ++ (replicate 3 $ (fmap connectRoom . randomiseOutLinks) corridor) - ++ [return $ connectRoom corridor] - ++[return $ connectRoom corridor,return $ connectRoom door] - ++ [shootingRange] - ++ (replicate 3 $ (fmap connectRoom . randomiseOutLinks) corridor) - ++[roomMiniIntro] - ++ (replicate 3 $ (fmap connectRoom . randomiseOutLinks) corridor) - ++ [return $ connectRoom corridor - ,return $ connectRoom door - ,slowDoorRoom] - ++ [return $ connectRoom corridor - ,spawnerRoom - ,return $ connectRoom corridor - ] - ) - $ (fmap connectRoom . randomiseOutLinks) corridor diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index 336413de2..c27a0d87a 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -116,17 +116,6 @@ insertInZone :: Int -> Int -> a -> IM.IntMap (IM.IntMap a) -> IM.IntMap (IM.IntM insertInZone x y obj = IM.insertWith f x $ IM.singleton y obj where f _ = IM.insert y obj --- the old version of this used a version of polysIntersect with intersectSegSeg' -boundClip :: Tree Room -> Bool -boundClip t = or $ map (uncurry polysIntersect) [(x,y) | x<- xs, y<-xs, x>y] - ++ map f [(ps,qs) | ps <- xs, qs <-xs, ps/=qs] - where xs = map _rmBound $ flatten t - f ([],qs) = False - f ((p:_),qs) = pointInPolygon p qs - -noBoundClip :: Tree Room -> Bool -noBoundClip = not . boundClip - shiftRoomTree :: Tree Room -> Tree Room shiftRoomTree (Node t []) = Node t [] shiftRoomTree (Node t ts) = Node t diff --git a/src/Dodge/Layout/Tree/Annotate.hs b/src/Dodge/Layout/Tree/Annotate.hs index f74f7dbac..ee81c1ae4 100644 --- a/src/Dodge/Layout/Tree/Annotate.hs +++ b/src/Dodge/Layout/Tree/Annotate.hs @@ -83,7 +83,9 @@ annoToRoomTree [StartRoom] = do h <- state $ randomR (200,400) pure . Right <$> randomiseOutLinks (shiftRoomBy ((-20,-20),0) $ roomRectAutoLinks w h) annoToRoomTree (SpecificRoom rt:_) = rt -annoToRoomTree (BossAno cr : _) = branchRectWith . fmap (pure . Left) $ bossRoom cr +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 diff --git a/src/Dodge/Layout/Tree/Shift.hs b/src/Dodge/Layout/Tree/Shift.hs index 37980fddd..89c1f2779 100644 --- a/src/Dodge/Layout/Tree/Shift.hs +++ b/src/Dodge/Layout/Tree/Shift.hs @@ -28,8 +28,8 @@ shiftRoomTreeSearch bs (Node r ts :<| ts') | roomIsClipping = Nothing | otherwise = fmap (r :) $ shiftRoomTreeSearch newBounds $ ts' >< children where - roomIsClipping = any (polysIntersect (_rmBound r)) bs - newBounds = _rmBound r : bs + roomIsClipping = or (polysIntersect <$> _rmBound r <*> bs) + newBounds = _rmBound r ++ bs children = fromList $ zipWith (\l -> applyToRoot (shiftRoomToLink l)) (_rmLinks r) ts @@ -48,8 +48,8 @@ shiftRoomTreeSearchAll bs (Node r ts :<| ts') (s:ss) -> concatMap (\l -> shiftRoomTreeSearchAll bs (Node (rm l) ss <| (ts' |> f l s))) ls where ls = init $ _rmLinks r - newBounds = _rmBound r : bs - roomIsClipping = any (polysOverlap (_rmBound r)) bs + newBounds = _rmBound r ++ bs + roomIsClipping = or (polysOverlap <$> _rmBound r <*> bs) rm l = r & rmLinks %~ delete l f l = applyToRoot (shiftRoomToLink l) {- | diff --git a/src/Dodge/LevelGen/StaticWalls.hs b/src/Dodge/LevelGen/StaticWalls.hs index 2f669d7af..11c3b82c9 100644 --- a/src/Dodge/LevelGen/StaticWalls.hs +++ b/src/Dodge/LevelGen/StaticWalls.hs @@ -16,29 +16,27 @@ import Data.List import Data.Maybe import qualified Data.IntMap as IM import qualified Data.Set as S - +-- | Describe a wall as two points. +-- Order is important: the wall face is to the left as you move from 'fst' +-- to 'snd'. type WallP = (Point2,Point2) - -- | Test whether lines are near parallel. -- Assumes non-zero length lines. nearParallel :: WallP -> WallP -> Bool nearParallel (a,b) (x,y) = dotV (a -.- b) (vNormal (x -.- y)) < 0.01 - -- | Test for near collinearity. -- Assumes non-zero length lines. nearCollinear :: WallP -> WallP -> Bool nearCollinear (a,b) (x,y) | a /= x = nearParallel (a,b) (x,y) && nearParallel (a,b) (a,x) | otherwise = nearParallel (a,b) (x,y) && nearParallel (a,b) (a,y) - -- | Remove inverse walls. removeInverseWalls :: [WallP] -> [WallP] removeInverseWalls ((a,b):ps) | (b,a) `elem` ps = removeInverseWalls $ delete (b,a) ps | otherwise = (a,b) : removeInverseWalls ps removeInverseWalls ps = ps - -- | Cut out a polygon from a set of walls, and check for errors in the -- created walls. -- If created walls are not consistent, rotate and expand poly and retry. @@ -51,7 +49,8 @@ cutWalls ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of where newWalls = cutWalls' ps wls errsL = mapMaybe (`checkWallLeft` newWalls) newWalls - +-- | As 'cutWalls', but rotate in the other direction. +cutWallsL :: [Point2] -> [WallP] -> [WallP] cutWallsL ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of [] -> newWalls -- _ -> cutWalls (expandPolyBy 100 ps) wls @@ -60,7 +59,6 @@ cutWallsL ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of where newWalls = cutWalls' ps wls errsL = mapMaybe (`checkWallLeft` newWalls) newWalls - -- | Cut out a polygon from a set of walls, and check for errors in the -- created walls. -- Give error if created walls are not consistent. @@ -79,7 +77,6 @@ cutWalls'' ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of where newWalls = cutWalls' ps wls errsL = mapMaybe (`checkWallLeft` newWalls) newWalls - -- | Given a specific wall and list of walls, checks that the number of walls leaving the -- second point is the same as the number of walls entering the second point of -- the specific wall. @@ -104,7 +101,6 @@ checkWallLeft (x,y) wls where ins = filter (\(a,b) -> a == x) wls outs = filter (\(a,b) -> b == x) wls - -- | Given a polygon of points and collection of walls, cuts out the polygon. -- Ie returns a new set of walls with a hole determined by anticlockwise ordering of the points. -- The overall procedure is: @@ -131,7 +127,6 @@ cutWalls' qs walls = (zs,cwals) = cutWallsWithPoints ps walls ps = orderPolygon qs rs = orderPolygon $ nub $ zs ++ qs - -- | Given a value and a poly, pushes the poly points out from the center by the -- value amount. expandPolyBy :: Float -> [Point2] -> [Point2] @@ -139,7 +134,6 @@ expandPolyBy x ps = map f ps where cp = 1/(fromIntegral (length ps)) *.* foldr (+.+) (0,0) ps f p = p +.+ x *.* (p -.- cp) - -- | Given a polygon expressed as a list of points and a collection of walls, -- returns: -- fst: points of the polygon's intersection with walls @@ -151,21 +145,20 @@ cutWallsWithPoints (p:ps) ws = foldr f ([],ws) (zip (p:ps) (ps++[p])) ( nub $ as ++ cutWallsPoints p1 p2 ws' , concatMap (cutWall p1 p2) ws' ) - -- | List the points of intersection between a segment and collection of walls. cutWallsPoints :: Point2 -> Point2 -> [WallP] -> [Point2] --cutWallsPoints p1 p2 ws = mapMaybe (\(x:y:_) -> intersectExtendedSegSeg p1 p2 x y) cutWallsPoints p1 p2 = mapMaybe (uncurry $ myIntersectSegSeg p1 p2) - -- | Given a segment and a wall, split the wall into two if it crosses the segment. cutWall :: Point2 -> Point2 -> WallP -> [WallP] cutWall p1 p2 (x,y) = case myIntersectSegSeg p1 p2 x y of Nothing -> [(x,y)] Just cp -> [(x,cp),(cp,y)] - -addPolyWalls :: [Point2] -> [WallP] -> [WallP] +addPolyWalls + :: [Point2] -- ^ Multiple walls described as a polygon. + -> [WallP] + -> [WallP] addPolyWalls (q:qs) walls = foldr addPolyWall walls (zip (q:qs) (qs++[q])) - -- | Add a new wall to a list of walls only if either -- 1. no wall already exists on the normal line from the new wall -- 2. any of the first existing walls hit on the normal line from the new wall @@ -176,40 +169,36 @@ addPolyWall :: WallP -> [WallP] -> [WallP] addPolyWall (p1,p2) walls = case maybeWs of Just ws -> if all (\(x,y) -> isLHS x y p3) ws - then walls - else (p1,p2) : walls + then walls + else (p1,p2) : walls Nothing -> ((p1,p2) : walls) where p3 = 0.5 *.* (p1 +.+ p2) p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1) maybeWs = fmap (map fst) - . listToMaybe - $ groupBy ((==) `on` (dist p3 . snd)) - wlsP + . listToMaybe + $ groupBy ((==) `on` (dist p3 . snd)) + wlsP wlsP :: [(WallP, Point2)] wlsP = sortBy (compare `on` (dist p3 . snd)) - . catMaybes - $ zipWith f walls maybes + . catMaybes + $ zipWith f walls maybes f a (Just b) = Just (a,b) f _ Nothing = Nothing maybes = map (uncurry $ myIntersectSegSeg p3 p4) walls - -- | Given a list of points and a point, returns a point in the list if any is close -- to the point. findClosePoint :: [Point2] -> Point2 -> Maybe Point2 findClosePoint ps p = find (\q -> dist p q < 5) ps - -- | Given a list of points and a point, returns the point if none in the list -- is close to the point. pointIfNotClose :: [Point2] -> Point2 -> Maybe Point2 pointIfNotClose ps p = case findClosePoint ps p of - Nothing -> Just p - _ -> Nothing - + Nothing -> Just p + _ -> Nothing -- | Fuses a point with one in a list if any are close enough. fusePoint :: [Point2] -> Point2 -> Point2 fusePoint ps p = fromMaybe p $ findClosePoint ps p - -- | Given a list of points and wall, moves the wall to be on the points if it is -- close to any of the points. -- If either wall point is not moved, this point gets added to the list. @@ -218,7 +207,6 @@ fuseWall (ps, (x,y)) = ( nub (x':y':ps) , (x',y') ) where x' = fusePoint ps x y' = fusePoint (x':ps) y - -- | Given list of points and collection of walls, fuses the wall ends if -- they are close to the list of points or each other. fuseWallsWith :: [Point2] -> [WallP] -> [WallP] @@ -227,10 +215,8 @@ fuseWallsWith zs ws = snd $ foldr fuseWalls' (zs, []) ws fuseWalls' w (ps, ws) = let (qs, w') = fuseWall (ps, w) in (qs, w' : ws) - -- | Test if fst p == snd p. wallIsZeroLength (x,y) = x == y - -- | Given a polygon and list of walls, removes walls inside the polygon. removeWallsInPolygon :: [Point2] -> [WallP] -> [WallP] removeWallsInPolygon ps = filter (not . cond) diff --git a/src/Dodge/Room.hs b/src/Dodge/Room.hs index 43c0cb136..aa49a53a2 100644 --- a/src/Dodge/Room.hs +++ b/src/Dodge/Room.hs @@ -56,7 +56,7 @@ roomC x y = Room , _rmPath = [] , _rmPS = [windowLine (x/2,0) (x/2,y-60) ] - , _rmBound = rectNSWE (y+5) (-5) (-5) (x+5) + , _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)] } where lnks = @@ -240,7 +240,7 @@ roomOctogon = Room , _rmLinks = lnks , _rmPath = allPairs $ map fst lnks , _rmPS = [] - , _rmBound = [(-20,30),(20,30),(60,70),(60,110),(20,150),(-20,150),(-60,110),(-60,70)] + , _rmBound = [[(-20,30),(20,30),(60,70),(60,110),(20,150),(-20,150),(-60,110),(-60,70)] ] } where lnks = [((0,140),0) ,((35,125),0-pi/4) @@ -369,7 +369,7 @@ deadEndRoom = Room , _rmLinks = lnks , _rmPath = [] , _rmPS = [PS (0,-10) 0 putLamp] - , _rmBound = rectNSWE 20 (-20) (-30) 30 + , _rmBound = [rectNSWE 20 (-20) (-30) 30] } where lnks = [((0,30) ,0) ] diff --git a/src/Dodge/Room/Airlock.hs b/src/Dodge/Room/Airlock.hs index 00e299509..ecdd07900 100644 --- a/src/Dodge/Room/Airlock.hs +++ b/src/Dodge/Room/Airlock.hs @@ -28,7 +28,7 @@ airlockOneWay n = Room (M.insert (DoorNumOpen n) True)) ] --, _rmBound = rectNSWE 90 30 (-30) 30 - , _rmBound = rectNSWE 75 15 0 40 + , _rmBound = [rectNSWE 75 15 0 40] } where lnks = [((0,85),0) ,((0, 5),pi) @@ -66,7 +66,7 @@ airlock0 n = Room (over worldState (M.insert (DoorNumOpen n) False)) ,PS (-25, 50) 0 putLamp ] - , _rmBound = rectNSWE 75 15 0 40 + , _rmBound = [rectNSWE 75 15 0 40] } where lnks = [((20,95),0) @@ -105,12 +105,12 @@ airlock90 n = Room ,PS (60, 60) 0 putLamp ] , _rmBound = - [ (10,10) + [[ (10,10) , (10,100) , (100,150) , (150,100) , (100,10) - ] + ]] } where cond w = or $ M.lookup (DoorNumOpen n) (_worldState w) diff --git a/src/Dodge/Room/Boss.hs b/src/Dodge/Room/Boss.hs index 050f5068d..c3087cad5 100644 --- a/src/Dodge/Room/Boss.hs +++ b/src/Dodge/Room/Boss.hs @@ -35,13 +35,14 @@ roomOctogon x = Room ,crystalLine (negate $ x/2,-x) (-x,negate (x/2)) ,blockLine (-40,40-x) (40,40-x) ] - , _rmBound = rectNSWE x (-x) (-x) x + , _rmBound = [rectNSWE x (-x) (-x) x] } where fx = 4 * x / 5 bossRoom :: RandomGen g => Creature -> State g Room -bossRoom cr = pure $ roomOctogon 300 & rmPS %~ ( PS (0,100) (negate $ pi/2) (PutCrit cr) :) +--bossRoom cr = pure $ roomOctogon 300 & rmPS %~ ( PS (0,100) (negate $ pi/2) (PutCrit cr) :) +bossRoom cr = pure $ roomCross 200 300 & rmPS %~ ( PS (0,100) (negate $ pi/2) (PutCrit cr) :) armouredChasers :: RandomGen g => State g Room armouredChasers = do @@ -52,3 +53,23 @@ armouredChasers = do where cs = (armourChaseCrit & crState . crDropsOnDeath .~ DropSpecific [0]) : replicate 4 chaseCrit + +roomCross + :: Float -- ^ First width/2 + -> Float -- ^ Second width/2 + -> Room +roomCross x y = Room + { _rmPolys = [rectNSWE y (-y) (-x) x + ,rectNSWE (-x) x y (-y) + ] + , _rmLinks = [((x,y-20),negate $ pi/2)] + , _rmPath = [] + , _rmPS = + [PS ( x, 0) 0 putLamp + ,PS (-x, 0) 0 putLamp + ,PS ( 0, x) 0 putLamp + ,PS ( 0,-x) 0 putLamp + ] + , _rmBound = [rectNSWE x (-x) (-x) x] + } + where diff --git a/src/Dodge/Room/Corridor.hs b/src/Dodge/Room/Corridor.hs index 77e4d00ef..f14dcdba5 100644 --- a/src/Dodge/Room/Corridor.hs +++ b/src/Dodge/Room/Corridor.hs @@ -15,7 +15,7 @@ corridor = Room , _rmLinks = lnks , _rmPath = concatMap (doublePair . (,) (20,60) . fst) lnks , _rmPS = [] - , _rmBound = rectNSWE 50 30 0 40 + , _rmBound = [ rectNSWE 50 30 0 40 ] } where lnks = @@ -31,7 +31,7 @@ corridorN = Room , _rmLinks = lnks , _rmPath = pth , _rmPS = [] - , _rmBound = rectNSWE 50 30 0 40 + , _rmBound = [ rectNSWE 50 30 0 40 ] } where lnks = [((20,70) ,0) ,((20,10) ,pi) @@ -46,7 +46,7 @@ tEast = Room , _rmLinks = lnks , _rmPath = concatMap (doublePair . (,) (0,60) . fst) lnks , _rmPS = [] - , _rmBound = rectNSWE 70 10 0 40 + , _rmBound = [ rectNSWE 70 10 0 40 ] } where lnks = [(( 30,60),-pi/2) ,((-30,60),pi/2) @@ -60,7 +60,7 @@ tWest = Room , _rmLinks = lnks , _rmPath = concatMap (doublePair . (,) (0,60) . fst) lnks , _rmPS = [] - , _rmBound = rectNSWE 70 10 0 40 + , _rmBound = [ rectNSWE 70 10 0 40 ] } where lnks = diff --git a/src/Dodge/Room/Data.hs b/src/Dodge/Room/Data.hs index 3c279b95a..9a0ee32b7 100644 --- a/src/Dodge/Room/Data.hs +++ b/src/Dodge/Room/Data.hs @@ -21,6 +21,6 @@ data Room = Room , _rmLinks :: [(Point2,Float)] , _rmPath :: [(Point2, Point2)] , _rmPS :: [PlacementSpot] - , _rmBound :: [Point2] + , _rmBound :: [ [Point2] ] } makeLenses ''Room diff --git a/src/Dodge/Room/Link.hs b/src/Dodge/Room/Link.hs index 712a29bc3..ce2aecdf6 100644 --- a/src/Dodge/Room/Link.hs +++ b/src/Dodge/Room/Link.hs @@ -69,7 +69,7 @@ shiftRoomBy shift@(pos,rot) r = $ over rmLinks (fmap (shiftLinkBy shift)) $ over rmPath (map (shiftPathPointBy shift)) $ over rmPS (fmap (shiftPSBy shift)) - $ over rmBound (map (shiftPointBy shift)) + $ over rmBound (fmap (map (shiftPointBy shift))) r shiftLinkBy (pos,rot) (p,r) = (shiftPointBy (pos,rot) p, r + rot) diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs index adbee9460..59e901bfc 100644 --- a/src/Dodge/Room/Procedural.hs +++ b/src/Dodge/Room/Procedural.hs @@ -4,7 +4,7 @@ Procedural creation of rooms and subroom parts. module Dodge.Room.Procedural ( roomRect , roomRectAutoLinks - , testRoom + , randomFourCornerRoom , centerVaultRoom ) where import Dodge.Data @@ -43,7 +43,7 @@ roomRect x y xn yn = Room , _rmLinks = lnks , _rmPath = concatMap doublePair pth , _rmPS = [PS (x/2,y/2) 0 putLamp] - , _rmBound = rectNSWE (y+5) (-5) (-5) (x+5) + , _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)] } where yd = (y - 40) / fromIntegral yn @@ -81,22 +81,17 @@ 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. --} +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' + , _rmBound = _rmBound r ++ _rmBound r' } - -{- -The top fourth of a room of a given height. --} +{- The top fourth of a room of a given height. -} fourth :: Float -- ^ Distance from center of room to top edge -> Room @@ -107,24 +102,13 @@ fourth w = Room , _rmPS = [PS (0,w/2) 0 putLamp ] - , _rmBound = [(w,w),(-w,w)] + , _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. --} +{- 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 @@ -147,7 +131,7 @@ fourthWall w = do , _rmLinks = [((0,w), 0)] , _rmPath = [((0,w),(0,0)),((0,0),(0,w))] , _rmPS = b - , _rmBound = [(w,w),(-w,w)] + , _rmBound = [[(0,0),(w,w),(-w,w)]] } fourthCorner :: Float -> Room @@ -159,7 +143,7 @@ fourthCorner w = Room ] , _rmPath = [((0,w),(0,0)),((0,0),(0,w))] , _rmPS = [PS (0,w) 0 putLamp] - , _rmBound = [(w,w),(0,2*w),(-w,w)] + , _rmBound = [[(w,w),(0,2*w),(-w,w)]] } fourthCornerWall :: RandomGen g => Float -> State g Room @@ -196,9 +180,9 @@ fourthCornerWall w = do ] , _rmPath = [((0,w),(0,0)),((0,0),(0,w))] , _rmPS = b - , _rmBound = [(w,w),(0,2*w),(-w,w)] + , _rmBound = [[(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 @@ -206,17 +190,20 @@ fillNothingPlacement pst r = replaceNothingWith x (PS p rot PutNothing: pss) = PS 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 - -testRoom :: RandomGen g => State g Room -testRoom = do +{- | 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) @@ -228,7 +215,6 @@ testRoom = do . foldr1 combineRooms $ zipWith (\r a -> shiftRoomBy ((0,0),a) r) corners [0,pi/2,pi,3*pi/2] ) - {- | Creates room with a central vault with doors around it. -} centerVaultRoom @@ -268,7 +254,7 @@ centerVaultRoom n w h d = do ] ++ concat (zipWith (\i r -> map (shiftPSBy ((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 + , _rmBound = [rectNSWE h (-h) (-w) w] } where col = dim $ dim $ bright red diff --git a/src/Dodge/Room/RoadBlock.hs b/src/Dodge/Room/RoadBlock.hs index a06d06215..85ee2c2f7 100644 --- a/src/Dodge/Room/RoadBlock.hs +++ b/src/Dodge/Room/RoadBlock.hs @@ -47,7 +47,7 @@ litCorridor90 = do , PS ( 20,h-40) 0 $ PutID 0 , PS (-20,h-80) 0 $ PutID 2 ] - , _rmBound = poly + , _rmBound = [poly] } noWeaponTest :: RandomGen g => State g (Tree (Either Room Room)) diff --git a/src/Dodge/Room/Treasure.hs b/src/Dodge/Room/Treasure.hs index 5bed42587..4b0fc6d73 100644 --- a/src/Dodge/Room/Treasure.hs +++ b/src/Dodge/Room/Treasure.hs @@ -39,7 +39,7 @@ triLootRoom w h = pure $ Room ,PS (0,h-15) 0 putLamp ,PS (0,-60) 0 putLamp ] - , _rmBound = convexHull $ tri ++ base + , _rmBound = [tri , base] } where tri =