justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Allow for complex room bounds for clip checks

Browse Source
This commit is contained in:
jgk
2021-05-03 00:57:17 +02:00
parent f71724ae8b
commit 2bf23db935
14 changed files with 92 additions and 152 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Floor.hs
+8 -52
View File
@@ -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
src/Dodge/Layout.hs
-11
View File
@@ -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
src/Dodge/Layout/Tree/Annotate.hs
+3 -1
View File
@@ -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
src/Dodge/Layout/Tree/Shift.hs
+4 -4
View File
@@ -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)
{- |
src/Dodge/LevelGen/StaticWalls.hs
+18 -32
View File
@@ -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)
src/Dodge/Room.hs
+3 -3
View File
@@ -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)
]
src/Dodge/Room/Airlock.hs
+4 -4
View File
@@ -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)
src/Dodge/Room/Boss.hs
+23 -2
View File
@@ -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
src/Dodge/Room/Corridor.hs
+4 -4
View File
@@ -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 =
src/Dodge/Room/Data.hs
+1 -1
View File
@@ -21,6 +21,6 @@ data Room = Room
, _rmLinks :: [(Point2,Float)]
, _rmPath :: [(Point2, Point2)]
, _rmPS :: [PlacementSpot]
, _rmBound :: [Point2]
, _rmBound :: [ [Point2] ]
}
makeLenses ''Room
src/Dodge/Room/Link.hs
+1 -1
View File
@@ -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)
src/Dodge/Room/Procedural.hs
+21 -35
View File
@@ -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
src/Dodge/Room/RoadBlock.hs
+1 -1
View File
@@ -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))
src/Dodge/Room/Treasure.hs
+1 -1
View File
@@ -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 =