Refactor, try to limit dependencies
This commit is contained in:
+278
-221
@@ -1,144 +1,166 @@
|
||||
{- | Procedural creation of rooms and subroom parts. -}
|
||||
module Dodge.Room.Procedural
|
||||
( roomRect
|
||||
, roomRectAutoLinks
|
||||
, randomFourCornerRoom
|
||||
, randomFourCornerRoomCrsIts
|
||||
, centerVaultRoom
|
||||
, combineRooms
|
||||
, linksAndPath
|
||||
, makeGrid
|
||||
) where
|
||||
import Dodge.Data
|
||||
import Dodge.Placement.Shift
|
||||
import Dodge.Default.Wall
|
||||
import Dodge.Default.Door
|
||||
--import Shape.Data
|
||||
import Dodge.PlacementSpot
|
||||
import Dodge.Placement.Instance
|
||||
import Dodge.RoomLink
|
||||
--import Dodge.Item.Weapon.Utility
|
||||
import Dodge.Room.Link
|
||||
import Dodge.Room.Path
|
||||
import Dodge.Default.Room
|
||||
--import Dodge.Item.Consumable
|
||||
--import Dodge.Item.Equipment
|
||||
--import Dodge.Item.Weapon
|
||||
import RandomHelp
|
||||
import Dodge.LevelGen.Data
|
||||
import Dodge.LevelGen.Switch
|
||||
import Dodge.Creature
|
||||
import Geometry
|
||||
import Picture
|
||||
import Data.Tile
|
||||
import LensHelp
|
||||
-- | Procedural creation of rooms and subroom parts.
|
||||
module Dodge.Room.Procedural (
|
||||
roomRect,
|
||||
roomRectAutoLinks,
|
||||
randomFourCornerRoom,
|
||||
randomFourCornerRoomCrsIts,
|
||||
centerVaultRoom,
|
||||
combineRooms,
|
||||
linksAndPath,
|
||||
makeGrid,
|
||||
) where
|
||||
|
||||
import qualified Data.Set as S
|
||||
import Data.Tile
|
||||
import Dodge.Creature
|
||||
import Dodge.Data.GenWorld
|
||||
import Dodge.Default.Door
|
||||
import Dodge.Default.Room
|
||||
import Dodge.LevelGen.Data
|
||||
import Dodge.LevelGen.Switch
|
||||
import Dodge.Placement.Instance
|
||||
import Dodge.Placement.Shift
|
||||
import Dodge.PlacementSpot
|
||||
import Dodge.Room.Link
|
||||
import Dodge.Room.Path
|
||||
import Dodge.RoomLink
|
||||
import Geometry
|
||||
import LensHelp
|
||||
import Picture
|
||||
import RandomHelp
|
||||
|
||||
--import Control.Lens
|
||||
-- This will need a cleanup, but it might change a bit first
|
||||
{- 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
|
||||
, _rmName = "rect"
|
||||
, _rmPath = foldMap doublePairSet pth
|
||||
--, _rmPos = map (roomposat (RoomPosOnPath S.empty)) posps
|
||||
-- ++ map (roomposat (RoomPosOffPath S.empty)) interposps
|
||||
, _rmPos = map makeonpos posps'
|
||||
++ map makeoffpos interposps'
|
||||
, _rmPmnts = []
|
||||
, _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)]
|
||||
, _rmFloor = Tiled [Tile
|
||||
{ _tilePoly = rectNSWE y 0 0 x
|
||||
, _tileZero = V2 0 0
|
||||
, _tileX = V2 1 0
|
||||
, _tileZ = 16
|
||||
} ]
|
||||
, _rmRandPSs = [psRandRanges (10,x-10) (10,y-10) (0,2*pi)]
|
||||
, _rmType = RectRoomType
|
||||
{ _numLinkEW = xn
|
||||
, _numLinkNS = yn
|
||||
, _linkGapEW = xd
|
||||
, _linkGapNS = yd
|
||||
, _rmWidth = x
|
||||
, _rmHeight = y
|
||||
roomRect ::
|
||||
-- | Width
|
||||
Float ->
|
||||
-- | Height
|
||||
Float ->
|
||||
-- | Number of links on vertical walls
|
||||
Int ->
|
||||
-- | Number of links on horizontal walls
|
||||
Int ->
|
||||
Room
|
||||
roomRect x y xn yn =
|
||||
defaultRoom
|
||||
{ _rmPolys = [rectNSWE y 0 0 x]
|
||||
, _rmLinks = lnks
|
||||
, _rmName = "rect"
|
||||
, _rmPath = foldMap doublePairSet pth
|
||||
, --, _rmPos = map (roomposat (RoomPosOnPath S.empty)) posps
|
||||
-- ++ map (roomposat (RoomPosOffPath S.empty)) interposps
|
||||
_rmPos =
|
||||
map makeonpos posps'
|
||||
++ map makeoffpos interposps'
|
||||
, _rmPmnts = []
|
||||
, _rmBound = [rectNSWE (y + 5) (-5) (-5) (x + 5)]
|
||||
, _rmFloor =
|
||||
Tiled
|
||||
[ Tile
|
||||
{ _tilePoly = rectNSWE y 0 0 x
|
||||
, _tileZero = V2 0 0
|
||||
, _tileX = V2 1 0
|
||||
, _tileZ = 16
|
||||
}
|
||||
]
|
||||
, _rmRandPSs = [psRandRanges (10, x -10) (10, y -10) (0, 2 * pi)]
|
||||
, _rmType =
|
||||
RectRoomType
|
||||
{ _numLinkEW = xn
|
||||
, _numLinkNS = yn
|
||||
, _linkGapEW = xd
|
||||
, _linkGapNS = yd
|
||||
, _rmWidth = x
|
||||
, _rmHeight = y
|
||||
}
|
||||
}
|
||||
}
|
||||
where
|
||||
yd = (y - 40) / fromIntegral yn
|
||||
xd = (x - 40) / fromIntegral xn
|
||||
somelnks poffset ps a = zip (map (+.+ poffset) ps) (repeat a)
|
||||
wlnks = somelnks (V2 0 20) (gridPoints 0 1 yd (yn+1)) ( pi/2)
|
||||
elnks = somelnks (V2 x 20) (gridPoints 0 1 yd (yn+1)) (-pi/2)
|
||||
nlnks = somelnks (V2 20 y) (gridPoints xd (xn+1) 0 1 ) 0
|
||||
slnks = somelnks (V2 20 0) (gridPoints xd (xn+1) 0 1 ) pi
|
||||
lnks = m North (FromEdge West) (FromEdge East) nlnks
|
||||
++ m East (FromEdge South) (FromEdge North) elnks
|
||||
++ m West (FromEdge South) (FromEdge North) wlnks
|
||||
++ m South (FromEdge West) (FromEdge East) slnks
|
||||
m edge edgefrom1 edgefrom2 = zipWith (lnkBothAnd (OnEdge edge) edgefrom1 edgefrom2) [0..]
|
||||
. zipCountDown
|
||||
wlnks = somelnks (V2 0 20) (gridPoints 0 1 yd (yn + 1)) (pi / 2)
|
||||
elnks = somelnks (V2 x 20) (gridPoints 0 1 yd (yn + 1)) (- pi / 2)
|
||||
nlnks = somelnks (V2 20 y) (gridPoints xd (xn + 1) 0 1) 0
|
||||
slnks = somelnks (V2 20 0) (gridPoints xd (xn + 1) 0 1) pi
|
||||
lnks =
|
||||
m North (FromEdge West) (FromEdge East) nlnks
|
||||
++ m East (FromEdge South) (FromEdge North) elnks
|
||||
++ m West (FromEdge South) (FromEdge North) wlnks
|
||||
++ m South (FromEdge West) (FromEdge East) slnks
|
||||
m edge edgefrom1 edgefrom2 =
|
||||
zipWith (lnkBothAnd (OnEdge edge) edgefrom1 edgefrom2) [0 ..]
|
||||
. zipCountDown
|
||||
pth = linksAndPath' lnks $ map (bimap (+.+ V2 20 20) (+.+ V2 20 20)) (makeGrid xd xn yd yn)
|
||||
makeonpos (p,a) = RoomPos p 0 (S.singleton $ RoomPosOnPath $ makerpedges a) NotLink 0
|
||||
makerpedges (a,b) = S.fromList
|
||||
[PathFromEdge South b
|
||||
,PathFromEdge North (yn-b)
|
||||
,PathFromEdge East (xn-a)
|
||||
,PathFromEdge West a
|
||||
]
|
||||
posps' = map (over _1 (+.+ V2 20 20)) $ gridPoints'' xd (xn+1) yd (yn+1)
|
||||
interposps' = map (over _1 (+.+ V2 (20 + xd/2) (20 + yd/2))) $ gridPoints'' xd xn yd yn
|
||||
makeoffpos (p,a) = RoomPos p 0 (S.singleton $ RoomPosOffPath $ makerpedges' a) NotLink 0
|
||||
makerpedges' (a,b) = S.fromList
|
||||
[PathFromEdge South b
|
||||
,PathFromEdge North (yn-(b+1))
|
||||
,PathFromEdge East (xn-(a+1))
|
||||
,PathFromEdge West a
|
||||
]
|
||||
makeonpos (p, a) = RoomPos p 0 (S.singleton $ RoomPosOnPath $ makerpedges a) NotLink 0
|
||||
makerpedges (a, b) =
|
||||
S.fromList
|
||||
[ PathFromEdge South b
|
||||
, PathFromEdge North (yn - b)
|
||||
, PathFromEdge East (xn - a)
|
||||
, PathFromEdge West a
|
||||
]
|
||||
posps' = map (over _1 (+.+ V2 20 20)) $ gridPoints'' xd (xn + 1) yd (yn + 1)
|
||||
interposps' = map (over _1 (+.+ V2 (20 + xd / 2) (20 + yd / 2))) $ gridPoints'' xd xn yd yn
|
||||
makeoffpos (p, a) = RoomPos p 0 (S.singleton $ RoomPosOffPath $ makerpedges' a) NotLink 0
|
||||
makerpedges' (a, b) =
|
||||
S.fromList
|
||||
[ PathFromEdge South b
|
||||
, PathFromEdge North (yn - (b + 1))
|
||||
, PathFromEdge East (xn - (a + 1))
|
||||
, PathFromEdge West a
|
||||
]
|
||||
|
||||
zipCountDown :: [a] -> [(Int,a)]
|
||||
zipCountDown :: [a] -> [(Int, a)]
|
||||
zipCountDown xs = zip [length xs - 1, length xs - 2 ..] xs
|
||||
|
||||
lnkBothAnd :: RoomLinkType -> (Int -> RoomLinkType) -> (Int -> RoomLinkType)
|
||||
-> Int -> (Int,(Point2,Float)) -> RoomLink
|
||||
lnkBothAnd rlt ltcon ltcon2 i (j,(p,a)) = RoomLink
|
||||
{ _rlType = S.fromList [OutLink,InLink,rlt,ltcon i,ltcon2 j]
|
||||
, _rlPos = p
|
||||
, _rlDir = a
|
||||
}
|
||||
lnkBothAnd ::
|
||||
RoomLinkType ->
|
||||
(Int -> RoomLinkType) ->
|
||||
(Int -> RoomLinkType) ->
|
||||
Int ->
|
||||
(Int, (Point2, Float)) ->
|
||||
RoomLink
|
||||
lnkBothAnd rlt ltcon ltcon2 i (j, (p, a)) =
|
||||
RoomLink
|
||||
{ _rlType = S.fromList [OutLink, InLink, rlt, ltcon i, ltcon2 j]
|
||||
, _rlPos = p
|
||||
, _rlDir = a
|
||||
}
|
||||
|
||||
{- Creates a rectangular room, automatically creates links and pathfinding graph at a sensible size. -}
|
||||
-- it is not clear to me that this works for very small rooms (but it does seem
|
||||
-- to do so)
|
||||
roomRectAutoLinks :: Float -> Float -> Room
|
||||
roomRectAutoLinks x y = roomRect x y (f x) (f y)
|
||||
& rmName .~ "autoRect"
|
||||
& rmPmnts .~ [mntLightLnkCond $ resetPLUse $ rprBool $ \rp _ -> isInLnk rp
|
||||
,mntLightLnkCond $ resetPLUse $ rprBool $ \rp _ -> isOutLnk rp]
|
||||
roomRectAutoLinks x y =
|
||||
roomRect x y (f x) (f y)
|
||||
& rmName .~ "autoRect"
|
||||
& rmPmnts
|
||||
.~ [ mntLightLnkCond $ resetPLUse $ rprBool $ \rp _ -> isInLnk rp
|
||||
, mntLightLnkCond $ resetPLUse $ rprBool $ \rp _ -> isOutLnk rp
|
||||
]
|
||||
where
|
||||
f z = max 1 $ (ceiling z - 40) `div` 60
|
||||
|
||||
{- Combines two rooms into one room.
|
||||
- will have to work out exactly what to do with combining links
|
||||
Mostly involves concatenation. -}
|
||||
combineRooms :: Room -> Room -> Room
|
||||
combineRooms r r' = defaultRoom
|
||||
{ _rmPolys = _rmPolys r ++ _rmPolys r'
|
||||
, _rmLinks = _rmLinks r ++ _rmLinks r'
|
||||
, _rmPath = S.map clampPath $ _rmPath r <> _rmPath r'
|
||||
, _rmPmnts = _rmPmnts r ++ _rmPmnts r'
|
||||
, _rmBound = _rmBound r ++ _rmBound r'
|
||||
, _rmPos = _rmPos r ++ _rmPos r'
|
||||
, _rmFloor = combineFloors (_rmFloor r) (_rmFloor r')
|
||||
, _rmShift = (V2 0 0 , 0)
|
||||
}
|
||||
combineRooms r r' =
|
||||
defaultRoom
|
||||
{ _rmPolys = _rmPolys r ++ _rmPolys r'
|
||||
, _rmLinks = _rmLinks r ++ _rmLinks r'
|
||||
, _rmPath = S.map clampPath $ _rmPath r <> _rmPath r'
|
||||
, _rmPmnts = _rmPmnts r ++ _rmPmnts r'
|
||||
, _rmBound = _rmBound r ++ _rmBound r'
|
||||
, _rmPos = _rmPos r ++ _rmPos r'
|
||||
, _rmFloor = combineFloors (_rmFloor r) (_rmFloor r')
|
||||
, _rmShift = (V2 0 0, 0)
|
||||
}
|
||||
|
||||
-- not that this assumes that any link paths are integral
|
||||
clampPath :: (Point2,Point2) -> (Point2, Point2)
|
||||
clampPath :: (Point2, Point2) -> (Point2, Point2)
|
||||
clampPath = bimap f f
|
||||
where
|
||||
f (V2 x y) = V2 (g x) (g y)
|
||||
@@ -146,130 +168,165 @@ clampPath = bimap f f
|
||||
|
||||
combineFloors :: Floor -> Floor -> Floor
|
||||
combineFloors = const
|
||||
|
||||
{- Randomly generate a top fourth of a room possibly with a wall.
|
||||
Add a light and a 'PutNothing' placement. -}
|
||||
quarterRoomTri :: RandomGen g => Float -> State g Room
|
||||
quarterRoomTri w = do
|
||||
b <- takeOne
|
||||
[ [ mntLS vShape (V2 0 w) (V3 0 (w-20) 70)
|
||||
, blockLine (V2 (w/2) (w/2)) (V2 (w/2) w)
|
||||
b <-
|
||||
takeOne
|
||||
[
|
||||
[ mntLS vShape (V2 0 w) (V3 0 (w -20) 70)
|
||||
, blockLine (V2 (w / 2) (w / 2)) (V2 (w / 2) w)
|
||||
]
|
||||
, [blockLine (V2 (w / 2) (w / 2)) (V2 (negate $ w / 2) (w / 2))]
|
||||
,
|
||||
[ blockLine (V2 (w / 2) (w / 2)) (V2 0 (w / 2))
|
||||
, blockLine (V2 (-29) w) (V2 0 (w / 2)) & plType . putWall . wlRotateTo .~ False
|
||||
]
|
||||
]
|
||||
, [ blockLine (V2 (w/2) (w/2)) (V2 (negate $ w/2) (w/2))]
|
||||
, [ blockLine (V2 (w/2) (w/2)) (V2 0 (w/2))
|
||||
, blockLine (V2 (-29) w) (V2 0 (w/2)) & plType . putWall . wlRotateTo .~ False
|
||||
]
|
||||
]
|
||||
pure $ defaultRoom
|
||||
{ _rmPolys = [ [V2 0 0,V2 w w,V2 (-w) w] ]
|
||||
, _rmLinks = [toBothLnk (V2 0 w, 0)]
|
||||
, _rmPath = foldMap doublePairSet
|
||||
[(V2 0 w,V2 0 (w-20))
|
||||
,(V2 0 (w-20),V2 (w-20) (w-20))
|
||||
,(V2 0 (w-20),V2 (55-w) (w-20))
|
||||
,(V2 (55-w) (w-20),V2 (20-w) (w-20))
|
||||
,(V2 0 (w-20),V2 0 0)
|
||||
,(V2 (55-w) (w-20),V2 0 0)
|
||||
]
|
||||
, _rmPmnts = b ++ [ mntLS iShape (V2 (w-20) w) (V3 (w-20) (w-20) 70) ]
|
||||
, _rmPos =
|
||||
[ RoomPos (V2 (w-20) (w-20)) pi S.empty NotLink 0
|
||||
, RoomPos (V2 (w-15) (w-25)) pi S.empty NotLink 0
|
||||
]
|
||||
, _rmBound = [[V2 0 0,V2 w w,V2 (-w) w]]
|
||||
}
|
||||
pure $
|
||||
defaultRoom
|
||||
{ _rmPolys = [[V2 0 0, V2 w w, V2 (- w) w]]
|
||||
, _rmLinks = [toBothLnk (V2 0 w, 0)]
|
||||
, _rmPath =
|
||||
foldMap
|
||||
doublePairSet
|
||||
[ (V2 0 w, V2 0 (w -20))
|
||||
, (V2 0 (w -20), V2 (w -20) (w -20))
|
||||
, (V2 0 (w -20), V2 (55 - w) (w -20))
|
||||
, (V2 (55 - w) (w -20), V2 (20 - w) (w -20))
|
||||
, (V2 0 (w -20), V2 0 0)
|
||||
, (V2 (55 - w) (w -20), V2 0 0)
|
||||
]
|
||||
, _rmPmnts = b ++ [mntLS iShape (V2 (w -20) w) (V3 (w -20) (w -20) 70)]
|
||||
, _rmPos =
|
||||
[ RoomPos (V2 (w -20) (w -20)) pi S.empty NotLink 0
|
||||
, RoomPos (V2 (w -15) (w -25)) pi S.empty NotLink 0
|
||||
]
|
||||
, _rmBound = [[V2 0 0, V2 w w, V2 (- w) w]]
|
||||
}
|
||||
|
||||
quarterRoomSquare :: RandomGen g => Float -> State g Room
|
||||
quarterRoomSquare w = do
|
||||
b <- takeOne
|
||||
[ [ mntLS vShape (V2 0 (2*w-20)) (V3 0 (2*w-40) 70)
|
||||
, blockLine (V2 (negate $ w/2) (w/2)) (V2 0 w)
|
||||
b <-
|
||||
takeOne
|
||||
[
|
||||
[ mntLS vShape (V2 0 (2 * w -20)) (V3 0 (2 * w -40) 70)
|
||||
, blockLine (V2 (negate $ w / 2) (w / 2)) (V2 0 w)
|
||||
]
|
||||
,
|
||||
[ mntLS vShape (V2 0 (2 * w -20)) (V3 0 (2 * w -40) 70)
|
||||
, blockLine (V2 (negate w) w) (V2 0 w)
|
||||
]
|
||||
,
|
||||
[ mntLS iShape (V2 (0.7 * w) (1.3 * w)) (V3 (0.7 * w -20) (1.3 * w -20) 70)
|
||||
, blockLine (V2 0 w) (V2 0 (w * 2))
|
||||
]
|
||||
]
|
||||
, [ mntLS vShape (V2 0 (2*w-20)) (V3 0 (2*w-40) 70)
|
||||
, blockLine (V2 (negate w) w ) (V2 0 w)
|
||||
]
|
||||
, [ mntLS iShape (V2 (0.7*w) (1.3*w)) (V3 (0.7*w-20) (1.3*w-20) 70)
|
||||
, blockLine (V2 0 w) (V2 0 (w*2))
|
||||
]
|
||||
]
|
||||
let thepoly = [ map toV2 [(0,0),(w,w),(0,2*w),(-w,w)] ]
|
||||
pure $ defaultRoom
|
||||
{ _rmPolys = thepoly
|
||||
, _rmLinks = map toBothLnk
|
||||
[ (V2 (w/2) (3*w/2), negate $ pi/4)
|
||||
, (V2 (negate $ w/2) (3*w/2), pi/4)
|
||||
]
|
||||
, _rmPath = foldMap doublePairSet
|
||||
[(V2 (0.5*w) (1.5*w),V2 (0.5*w-20) (1.5*w-20))
|
||||
,(V2 (-0.5*w) (1.5*w),V2 (-0.5*w+20) (1.5*w-20))
|
||||
,(V2 0 (2*w-40),V2 (-0.5*w+20) (1.5*w-20))
|
||||
,(V2 0 (2*w-40),V2 (0.5*w-20) (1.5*w-20))
|
||||
,(V2 (w-20) (w-20),V2 (0.5*w-20) (1.5*w-20))
|
||||
,(V2 (20-w) (w-20),V2 (-0.5*w+20) (1.5*w-20))
|
||||
--,(V2 (40-w) (w),V2 0 (w-40))
|
||||
,(V2 (20-w) (w-20),V2 0 (w-40))
|
||||
,(V2 0 0,V2 0 (w-40))
|
||||
-- ,(V2 (20-w) (w-20),V2 (40-w) (w))
|
||||
]
|
||||
, _rmPmnts = b ++ [ blockLine (V2 (w/2) (w/2)) (V2 0 w) ]
|
||||
, _rmPos = [ RoomPos p pi S.empty NotLink 0
|
||||
| p <- [V2 20 (2*w-40),V2 25 (2*w-45)] ]
|
||||
--, _rmBound = [map toV2 [(w,w),(0,2*w),(-w,w)]]
|
||||
, _rmBound = [ map toV2 [(0,0),(w,w),(0,2*w),(-w,w)] ]
|
||||
}
|
||||
{- | A randomly generate room based on four randomly generated corners.
|
||||
Tight corridors, random placements. -}
|
||||
let thepoly = [map toV2 [(0, 0), (w, w), (0, 2 * w), (- w, w)]]
|
||||
pure $
|
||||
defaultRoom
|
||||
{ _rmPolys = thepoly
|
||||
, _rmLinks =
|
||||
map
|
||||
toBothLnk
|
||||
[ (V2 (w / 2) (3 * w / 2), negate $ pi / 4)
|
||||
, (V2 (negate $ w / 2) (3 * w / 2), pi / 4)
|
||||
]
|
||||
, _rmPath =
|
||||
foldMap
|
||||
doublePairSet
|
||||
[ (V2 (0.5 * w) (1.5 * w), V2 (0.5 * w -20) (1.5 * w -20))
|
||||
, (V2 (-0.5 * w) (1.5 * w), V2 (-0.5 * w + 20) (1.5 * w -20))
|
||||
, (V2 0 (2 * w -40), V2 (-0.5 * w + 20) (1.5 * w -20))
|
||||
, (V2 0 (2 * w -40), V2 (0.5 * w -20) (1.5 * w -20))
|
||||
, (V2 (w -20) (w -20), V2 (0.5 * w -20) (1.5 * w -20))
|
||||
, (V2 (20 - w) (w -20), V2 (-0.5 * w + 20) (1.5 * w -20))
|
||||
, --,(V2 (40-w) (w),V2 0 (w-40))
|
||||
(V2 (20 - w) (w -20), V2 0 (w -40))
|
||||
, (V2 0 0, V2 0 (w -40))
|
||||
-- ,(V2 (20-w) (w-20),V2 (40-w) (w))
|
||||
]
|
||||
, _rmPmnts = b ++ [blockLine (V2 (w / 2) (w / 2)) (V2 0 w)]
|
||||
, _rmPos =
|
||||
[ RoomPos p pi S.empty NotLink 0
|
||||
| p <- [V2 20 (2 * w -40), V2 25 (2 * w -45)]
|
||||
]
|
||||
, --, _rmBound = [map toV2 [(w,w),(0,2*w),(-w,w)]]
|
||||
_rmBound = [map toV2 [(0, 0), (w, w), (0, 2 * w), (- w, w)]]
|
||||
}
|
||||
|
||||
{- | A randomly generate room based on four randomly generated corners.
|
||||
Tight corridors, random placements.
|
||||
-}
|
||||
randomFourCornerRoom :: RandomGen g => [Item] -> State g Room
|
||||
randomFourCornerRoom its = do
|
||||
nCrits <- state $ randomR (1,3)
|
||||
crits <- takeN nCrits <=< shuffle $ [spreadGunCrit,pistolCrit,autoCrit,armourChaseCrit]
|
||||
++ replicate 20 chaseCrit
|
||||
nCrits <- state $ randomR (1, 3)
|
||||
crits <-
|
||||
takeN nCrits <=< shuffle $
|
||||
[spreadGunCrit, pistolCrit, autoCrit, armourChaseCrit]
|
||||
++ replicate 20 chaseCrit
|
||||
randomFourCornerRoomCrsIts crits its
|
||||
{- | A randomly generate room based on four randomly generated corners.
|
||||
Tight corridors. -}
|
||||
|
||||
{- | A randomly generate room based on four randomly generated corners.
|
||||
Tight corridors.
|
||||
-}
|
||||
randomFourCornerRoomCrsIts :: RandomGen g => [Creature] -> [Item] -> State g Room
|
||||
randomFourCornerRoomCrsIts crits its = do
|
||||
corners <- replicateM 4 . join $ takeOne [quarterRoomTri 100, quarterRoomSquare 100]
|
||||
let putitms = map (\it -> sps0 (PutFlIt it) & plSpot .~ anyUnusedSpot) its
|
||||
let putitms = map (\it -> sps0 (PutFlIt it) & plSpot .~ anyUnusedSpot) its
|
||||
putcrits = map (\cr -> sps0 (PutCrit cr) & plSpot .~ unusedSpotAwayFromLink 50) crits
|
||||
shuffleLinks
|
||||
. (rmPmnts .++~ (sps0 putLamp : putitms ++ putcrits))
|
||||
shuffleLinks
|
||||
. (rmPmnts .++~ (sps0 putLamp : putitms ++ putcrits))
|
||||
. foldr1 combineRooms
|
||||
$ zipWith (\r a -> moveRoomBy (V2 0 0,a) r) corners [0,pi/2,pi,3*pi/2]
|
||||
{- | Creates room with a central vault with doors around it. -}
|
||||
centerVaultRoom
|
||||
:: Float -- ^ Width
|
||||
-> Float -- ^ Height
|
||||
-> Float -- ^ Vault dimensions
|
||||
-> State g Room
|
||||
centerVaultRoom w h d = return $ defaultRoom
|
||||
{ _rmPolys = [rectNSWE h (-h) (-w) w]
|
||||
, _rmLinks =
|
||||
[outLink (V2 0 h) 0
|
||||
,outLink (V2 w 0) (-pi/2)
|
||||
,outLink (V2 (-w) 0) (pi/2)
|
||||
, inLink (V2 0 (-h)) pi ]
|
||||
, _rmPath = mempty
|
||||
, _rmPmnts =
|
||||
[sps0 $ PutWall (reverse $ rectNSWE d (d - 30) (d - 30) d ) defaultWall
|
||||
,sps0 $ PutWall (reverse $ rectNSWE d (d - 30) (30 - d) (-d)) defaultWall
|
||||
,sps0 $ PutWall (reverse $ rectNSWE (-d) (30 - d) (d - 30) d ) defaultWall
|
||||
,sps0 $ PutWall (reverse $ rectNSWE (-d) (30 - d) (30 - d) (-d)) defaultWall
|
||||
]
|
||||
++ map (\a -> mntLS vShape (rotateV a $ V2 0 d) (rotate3z a $ V3 0 (d+30) 70))
|
||||
[0,0.5*pi,pi,1.5*pi]
|
||||
++ concatMap (\r -> map (shiftPlacement (V2 0 0,r)) theDoor)
|
||||
[0,pi/2,pi,3*pi/2]
|
||||
, _rmBound = [rectNSWE h (-h) (-w) w]
|
||||
, _rmName = "cenVault"
|
||||
}
|
||||
$ zipWith (\r a -> moveRoomBy (V2 0 0, a) r) corners [0, pi / 2, pi, 3 * pi / 2]
|
||||
|
||||
-- | Creates room with a central vault with doors around it.
|
||||
centerVaultRoom ::
|
||||
-- | Width
|
||||
Float ->
|
||||
-- | Height
|
||||
Float ->
|
||||
-- | Vault dimensions
|
||||
Float ->
|
||||
State g Room
|
||||
centerVaultRoom w h d =
|
||||
return $
|
||||
defaultRoom
|
||||
{ _rmPolys = [rectNSWE h (- h) (- w) w]
|
||||
, _rmLinks =
|
||||
[ outLink (V2 0 h) 0
|
||||
, outLink (V2 w 0) (- pi / 2)
|
||||
, outLink (V2 (- w) 0) (pi / 2)
|
||||
, inLink (V2 0 (- h)) pi
|
||||
]
|
||||
, _rmPath = mempty
|
||||
, _rmPmnts =
|
||||
[ sps0 $ PutWall (reverse $ rectNSWE d (d - 30) (d - 30) d) defaultWall
|
||||
, sps0 $ PutWall (reverse $ rectNSWE d (d - 30) (30 - d) (- d)) defaultWall
|
||||
, sps0 $ PutWall (reverse $ rectNSWE (- d) (30 - d) (d - 30) d) defaultWall
|
||||
, sps0 $ PutWall (reverse $ rectNSWE (- d) (30 - d) (30 - d) (- d)) defaultWall
|
||||
]
|
||||
++ map
|
||||
(\a -> mntLS vShape (rotateV a $ V2 0 d) (rotate3z a $ V3 0 (d + 30) 70))
|
||||
[0, 0.5 * pi, pi, 1.5 * pi]
|
||||
++ concatMap
|
||||
(\r -> map (shiftPlacement (V2 0 0, r)) theDoor)
|
||||
[0, pi / 2, pi, 3 * pi / 2]
|
||||
, _rmBound = [rectNSWE h (- h) (- w) w]
|
||||
, _rmName = "cenVault"
|
||||
}
|
||||
where
|
||||
col = dim $ dim $ bright red
|
||||
theDoor =
|
||||
[ pContID (PS (V2 35 (d+4)) 0) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect)
|
||||
$ \btid -> jspsJ (V2 0 (d-10)) 0 (PutSlideDr (thedoor btid) thewall DoorObstacle 1 (V2 (-21) 0) (V2 0 0))
|
||||
$ sPS (V2 0 (d-10)) 0 (PutSlideDr (thedoor btid) thewall DoorObstacle 1 (V2 21 0) (V2 0 0))
|
||||
theDoor =
|
||||
[ pContID (PS (V2 35 (d + 4)) 0) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect) $
|
||||
\btid ->
|
||||
jspsJ (V2 0 (d -10)) 0 (PutSlideDr (thedoor btid) thewall DoorObstacle 1 (V2 (-21) 0) (V2 0 0)) $
|
||||
sPS (V2 0 (d -10)) 0 (PutSlideDr (thedoor btid) thewall DoorObstacle 1 (V2 21 0) (V2 0 0))
|
||||
]
|
||||
thewall = switchWallCol col
|
||||
thedoor btid = defaultDoor
|
||||
& drTrigger .~ WdBlBtOn btid
|
||||
& drSpeed .~ 2
|
||||
thedoor btid =
|
||||
defaultDoor
|
||||
& drTrigger .~ WdBlBtOn btid
|
||||
& drSpeed .~ 2
|
||||
|
||||
Reference in New Issue
Block a user