788 lines
33 KiB
Haskell
788 lines
33 KiB
Haskell
module Dodge.Rooms where
|
|
-- imports {{{
|
|
import Dodge.Data
|
|
import Dodge.Item.Weapon
|
|
import Dodge.Critters
|
|
import Dodge.LevelGen
|
|
import Dodge.Base
|
|
import Dodge.RandomHelp
|
|
import Dodge.Prototypes
|
|
import Dodge.Path
|
|
import Dodge.Layout
|
|
import Dodge.LightSources
|
|
import Dodge.SoundLogic
|
|
|
|
import Geometry
|
|
import Picture
|
|
|
|
import qualified SDL.Mixer as Mix
|
|
|
|
import Control.Monad.State
|
|
import Control.Monad.Loops
|
|
import Control.Lens
|
|
import System.Random
|
|
|
|
import Data.List
|
|
import Data.Maybe
|
|
import Data.Tree
|
|
import Data.Either
|
|
import Data.Function
|
|
import qualified Data.Map as M
|
|
|
|
import Data.Graph.Inductive.Graph hiding ((&))
|
|
import Data.Graph.Inductive.Basic
|
|
import Data.Graph.Inductive.PatriciaTree
|
|
import Data.Graph.Inductive.NodeMap
|
|
|
|
import qualified Data.IntMap.Strict as IM
|
|
-- }}}
|
|
-- definition of individual rooms
|
|
airlockOneWay :: Int -> Room
|
|
airlockOneWay n = Room
|
|
{ _rmPolys = [rectNSWE 90 0 0 40]
|
|
, _rmLinks = lnks
|
|
, _rmPath = []
|
|
, _rmPS = [PS (0,15) 0 $ PutTriggerDoor col (not . cond) (0,0) (0,40)
|
|
,PS (0,75) 0 $ PutTriggerDoor col (cond) (0,0) (0,40)
|
|
,PS (35,45) (pi/2) $ PutButton $ makeButton col (over worldState
|
|
(M.insert (DoorNumOpen n) True))
|
|
]
|
|
--, _rmBound = rectNSWE 90 30 (-30) 30
|
|
, _rmBound = rectNSWE 75 15 0 40
|
|
}
|
|
where lnks = [((0,85),0)
|
|
,((0, 5),pi)
|
|
]
|
|
cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
|
|
col = dim $ dim $ bright red
|
|
airlock :: Int -> Room
|
|
airlock n = Room
|
|
{ _rmPolys = [rectNSWE 90 0 0 40]
|
|
, _rmLinks = lnks
|
|
, _rmPath = [((20,85),(20,45))
|
|
,((20,45),(20, 5))
|
|
]
|
|
, _rmPS = [PS (0,15) 0 $ PutTriggerDoor col (not . cond) (0,0) (40,0)
|
|
,PS (0,75) 0 $ PutTriggerDoor col (cond) (0,0) (40,0)
|
|
,PS (35,45) (pi/2) $ PutButton $ makeSwitch col
|
|
(over worldState (M.insert (DoorNumOpen n) True))
|
|
(over worldState (M.insert (DoorNumOpen n) False))
|
|
]
|
|
, _rmBound = rectNSWE 75 15 0 40
|
|
}
|
|
where lnks = [((20,85),0)
|
|
,((20, 5),pi)
|
|
]
|
|
cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
|
|
col = dim $ dim $ bright red
|
|
corridor :: Room
|
|
corridor = Room
|
|
{ _rmPolys = [rectNSWE 80 0 0 40
|
|
,[(0,80), (0,80) +.+ rotateV (pi/3) (40,0),(40,80)]
|
|
,[(40,0), (0,0) +.+ rotateV (0-pi/3) (40,0),( 0, 0)]
|
|
]
|
|
, _rmLinks = lnks
|
|
, _rmPath = concatMap (doublePair . (,) (20,60)) $ map fst lnks
|
|
, _rmPS = []
|
|
, _rmBound = rectNSWE 50 30 0 40
|
|
}
|
|
where lnks = [((20,70) ,0)
|
|
,((20,80) +.+ rotateV (0-pi/3) (-20,0), pi/6)
|
|
,((20,80) +.+ rotateV ( pi/3) ( 20,0),0-pi/6)
|
|
,((20,10) ,pi)
|
|
]
|
|
corridorN :: Room
|
|
corridorN = Room
|
|
{ _rmPolys = [rectNSWE 80 0 0 40
|
|
]
|
|
, _rmLinks = lnks
|
|
, _rmPath = pth
|
|
, _rmPS = []
|
|
, _rmBound = rectNSWE 50 30 0 40
|
|
}
|
|
where lnks = [((20,70) ,0)
|
|
,((20,10) ,pi)
|
|
]
|
|
pth = doublePair ((20,70),(20,10))
|
|
tEast :: Room
|
|
tEast = Room
|
|
{ _rmPolys = [rectNSWE 80 0 (-20) (20)
|
|
,rectNSWE 80 40 (-40) 40
|
|
]
|
|
, _rmLinks = lnks
|
|
, _rmPath = concatMap (doublePair . (,) (0,60)) $ map fst lnks
|
|
, _rmPS = []
|
|
, _rmBound = rectNSWE 70 10 0 40
|
|
}
|
|
where lnks = [(( 30,60),-pi/2)
|
|
,((-30,60),pi/2)
|
|
,((0,10),pi)
|
|
]
|
|
tWest :: Room
|
|
tWest = Room
|
|
{ _rmPolys = [rectNSWE 80 0 (-20) (20)
|
|
,rectNSWE 80 40 (-40) 40
|
|
]
|
|
, _rmLinks = lnks
|
|
, _rmPath = concatMap (doublePair . (,) (0,60)) $ map fst lnks
|
|
, _rmPS = []
|
|
, _rmBound = rectNSWE 70 10 0 40
|
|
}
|
|
where lnks = [((-30,60),pi/2)
|
|
,(( 30,60),-pi/2)
|
|
,((0,10),pi)
|
|
]
|
|
roomC :: Float -> Float -> Room
|
|
roomC x y = Room
|
|
{ _rmPolys = [rectNSWE y 0 0 x]
|
|
, _rmLinks = lnks
|
|
, _rmPath = []
|
|
, _rmPS = [PS (0,0) 0 $ PutWindowBlock (x/2,0) (x/2,y-60)
|
|
]
|
|
--, _rmBound = rectNSWE y 0 0 x
|
|
, _rmBound = []
|
|
}
|
|
where lnks = [( (x-20, 0),pi)
|
|
,( ( 20, 0),pi)
|
|
,( ( 0, 20),pi/2)
|
|
]
|
|
|
|
makeRect :: Float -> Float -> [(Point2,Point2)]
|
|
makeRect x y = [((0,0),(x,0))
|
|
,((0,0),(0,y))
|
|
,((x,y),(x,0))
|
|
,((x,y),(0,y))
|
|
]
|
|
|
|
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
|
|
]
|
|
|
|
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
|
|
|
|
roomPadCut :: [Point2] -> Point2 -> Room
|
|
roomPadCut ps p = Room
|
|
{ _rmPolys = [ps]
|
|
, _rmLinks = [(p,0),((0,0),pi)]
|
|
, _rmPath = [((0,0),p)]
|
|
, _rmPS = []
|
|
, _rmBound = []
|
|
}
|
|
|
|
roomRect' :: Float -> Float -> Int -> Int -> Room
|
|
roomRect' x y a b = Room
|
|
{ _rmPolys = [rectNSWE y 0 0 x ]
|
|
, _rmLinks = lnks
|
|
, _rmPath = concatMap doublePair pth
|
|
, _rmPS = [PS (x/2,y/2) 0 $ basicLS]
|
|
, _rmBound = rectNSWE (y+5) (-5) (-5) (x+5)
|
|
}
|
|
where yn,xn :: Int
|
|
yn = b
|
|
yd = (y - 40) / fromIntegral yn
|
|
xn = a
|
|
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)
|
|
|
|
roomRect :: Float -> Float -> Room
|
|
roomRect x y = roomRect' x y ((ceiling x - 40) `div` 60) ((ceiling y - 40) `div` 60)
|
|
|
|
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)
|
|
|
|
door :: Room
|
|
door = Room
|
|
{ _rmPolys = [rectNSWE 40 0 0 40]
|
|
, _rmLinks = lnks
|
|
, _rmPath = [((20,35),(20,5))]
|
|
-- door extends into side walls (for shadows as rendered 12/03)
|
|
, _rmPS = [PS (0,20) 0 $ PutAutoDoor (0,0) (40,0)]
|
|
, _rmBound = []
|
|
}
|
|
where lnks = [((20,35),0)
|
|
,((20, 5),pi)
|
|
]
|
|
roomPillars :: Room
|
|
roomPillars = over rmLinks init $ set rmPS plmnts $ roomRect' 240 240 2 2
|
|
where plmnts = g 180 150 90 60
|
|
f a x b y = putBlockRect a x b y
|
|
-- putWallBlocks (a,b) (a,y)
|
|
-- ++ putWallBlocks (a,y) (x,y)
|
|
-- ++ putWallBlocks (x,y) (x,b)
|
|
-- ++ putWallBlocks (x,b) (a,b)
|
|
g a b c d = f a b a b ++ f a b c d ++ f c d a b ++ f c d c d
|
|
|
|
|
|
putBlockRect a x b y = putWallBlocks (a,b) (a,y)
|
|
++ putWallBlocks (a,y) (x,y)
|
|
++ putWallBlocks (x,y) (x,b)
|
|
++ putWallBlocks (x,b) (a,b)
|
|
putBlockV a x b y = putWallBlocks (a,b) (a,y)
|
|
++ putWallBlocks (x,b) (a,b)
|
|
putBlockC a x b y = putWallBlocks (a,b) (a,y)
|
|
++ putWallBlocks (x,b) (a,b)
|
|
++ putWallBlocks (a,y) (x,y)
|
|
putBlockN a x b y = putWallBlocks (a,b) (a,y)
|
|
++ putWallBlocks (x,b) (a,b)
|
|
++ putWallBlocks (x,y) (x,b)
|
|
|
|
branchWith :: Room -> [Tree Room] -> Tree (Either Room Room)
|
|
branchWith r ts = Node (Left r) $ [return $ Right door] ++ fmap (fmap Left) ts
|
|
|
|
glassSwitchBack :: RandomGen g => State g Room
|
|
glassSwitchBack = do
|
|
wth <- state $ randomR (200,400)
|
|
hgt <- state $ randomR (400,600)
|
|
wllen <- state $ randomR (60,wth/2-40)
|
|
let hf = hgt/5
|
|
let plmnts = [PS (0,0) 0 $ PutWindowBlock (wth-60, hf) (wllen,hf)
|
|
,PS (0,0) 0 $ PutWindowBlock (wth-wllen,2*hf) (60, 2*hf)
|
|
,PS (0,0) 0 $ PutWindowBlock (wth-60, 3*hf) (wllen,3*hf)
|
|
,PS (0,0) 0 $ PutWindowBlock (wth-wllen,4*hf) (60, 4*hf)
|
|
]
|
|
++ putWallBlocks ( 0, 1*hf) (wllen,1*hf)
|
|
++ putWallBlocks (wth-wllen, 2*hf) ( wth,2*hf)
|
|
++ putWallBlocks ( 0, 3*hf) (wllen,3*hf)
|
|
++ putWallBlocks (wth-wllen, 4*hf) ( wth,4*hf)
|
|
return $ set rmPS plmnts $ roomRect' wth hgt 2 6
|
|
|
|
manyDoors :: Int -> Tree (Either Room Room)
|
|
manyDoors i = treePost (replicate i (Left door)) $ Right door
|
|
|
|
glassLesson :: RandomGen g => State g (Tree (Either Room Room))
|
|
glassLesson = do
|
|
corridors <- sequence $ replicate 3 $ fmap Left $ randLinks corridor
|
|
return $ Node (Left $ botRoom) [deadRoom door,uppers, treePost (Left door : corridors) $ Right door]
|
|
where uppers = Node (Left door) [deadRoom topRoom]
|
|
botRoom = set rmPS botplmnts
|
|
$ roomRect' 200 200 1 1
|
|
topRoom = set rmPS topplmnts
|
|
$ roomRect' 200 200 1 1
|
|
botplmnts = [PS (0,0) 0 $ PutWindow (rectNSWE (200) 0 (90) (110))
|
|
$ withAlpha 0.5 aquamarine
|
|
,PS (50,100) 0 $ PutCrit miniGunCrit
|
|
,PS (50,50) 0 basicLS
|
|
]
|
|
topplmnts = [PS (0,0) 0 $ PutWindowBlock (100,200) (100,0)
|
|
,PS (50,100) 0 $ PutCrit miniGunCrit
|
|
,PS (50,50) 0 basicLS
|
|
]
|
|
|
|
miniRoom1 :: RandomGen g => State g Room
|
|
miniRoom1 = do
|
|
wth <- state $ randomR (200,400)
|
|
hgt <- state $ randomR (400,600)
|
|
wllen <- state $ randomR (60,wth/2-40)
|
|
let hf = hgt/5
|
|
cry <- randomRanges [--50+2*hf,30+3*hf
|
|
50+3*hf,30+4*hf
|
|
,50+4*hf,30+5*hf
|
|
]
|
|
crx <- state $ randomR (wllen,wth-(wllen+40))
|
|
let plmnts = [PS (0,0) 0 $ PutWindowBlock (wth-60, 40+hf) (wllen,40+hf)
|
|
,PS (0,0) 0 $ PutWindowBlock (wth-wllen,40+2*hf) (60,40+2*hf)
|
|
,PS (0,0) 0 $ PutWindowBlock (wth-60, 40+3*hf) (wllen,40+3*hf)
|
|
,PS (0,0) 0 $ PutWindowBlock (wth-wllen,40+4*hf) (60,40+4*hf)
|
|
,PS (crx,cry) 0 $ PutCrit miniGunCrit
|
|
,PS (wth-20,hgt/2+40) 0 $ randC
|
|
,PS (wth/2,hgt/2) 0 basicLS
|
|
]
|
|
++ putWallBlocks ( 0, 40+1*hf) (wllen,40+1*hf)
|
|
++ putWallBlocks (wth-wllen, 40+2*hf) ( wth,40+2*hf)
|
|
++ putWallBlocks ( 0, 40+3*hf) (wllen,40+3*hf)
|
|
++ putWallBlocks (wth-wllen, 40+4*hf) ( wth,40+4*hf)
|
|
return $ set rmPS plmnts $ shiftRoomBy ((0,40),0) $ roomRect' wth hgt 2 4
|
|
|
|
miniTree2 :: RandomGen g => State g (Tree (Either Room Room))
|
|
miniTree2 = miniRoom1 >>= randLinks >>= changeLinkTo (\p -> (snd . fst) p < 70)
|
|
>>= return . flip branchWith (replicate 3 $ treePost [door,corridor]
|
|
critInDeadEnd )
|
|
|
|
miniRoom3 :: RandomGen g => State g (Tree (Either Room Room))
|
|
miniRoom3 = do
|
|
w <- state $ randomR (300,400)
|
|
h <- state $ randomR (300,400)
|
|
let l = -70
|
|
let r = 70
|
|
let cp = (0,h/2+40)
|
|
let f = rot90Around cp
|
|
let f2 = f . f
|
|
let f3 = f . f .f
|
|
let cpa p = p +.+ cp
|
|
let bl = putWallBlocks (cpa (-20,-40)) (cpa (-20,-80))
|
|
let br = putWallBlocks (cpa (20,-40)) (cpa (20,-80))
|
|
let bm = putWallBlocks (cpa (25,-35)) (cpa (35,-25))
|
|
let b = PutBlock [5,20,20] (greyN 0.5) [(-10,-60)
|
|
,( 10,-60)
|
|
,( 10,-80)
|
|
,(-10,-80)
|
|
]
|
|
let plmnts = [PS cp 0 $ PutCrit miniGunCrit
|
|
,PS cp 0 $ PutWindowBlock (0,-40) (0,-80)
|
|
,PS cp (1*pi/4) $ PutWindowBlock (0,-40) (0,-80)
|
|
,PS cp (2*pi/4) $ PutWindowBlock (0,-40) (0,-80)
|
|
,PS cp (3*pi/4) $ PutWindowBlock (0,-40) (0,-80)
|
|
,PS cp (4*pi/4) $ PutWindowBlock (0,-40) (0,-80)
|
|
,PS cp (5*pi/4) $ PutWindowBlock (0,-40) (0,-80)
|
|
,PS cp (6*pi/4) $ PutWindowBlock (0,-40) (0,-80)
|
|
,PS cp (7*pi/4) $ PutWindowBlock (0,-40) (0,-80)
|
|
,PS cp (pi/8) b
|
|
,PS cp (pi/8+1*pi/4) b
|
|
,PS cp (pi/8+2*pi/4) b
|
|
,PS cp (pi/8+3*pi/4) b
|
|
,PS cp (pi/8+4*pi/4) b
|
|
,PS cp (pi/8+5*pi/4) b
|
|
,PS cp (pi/8+6*pi/4) b
|
|
,PS cp (pi/8+7*pi/4) b
|
|
,PS (w/2,h/2) 0 basicLS
|
|
]
|
|
randomiseLinks $ set rmPS plmnts $ roomRect w h
|
|
|
|
rot90Around :: Point2 -> Point2 -> Point2
|
|
rot90Around cen p = cen +.+ vNormal (p -.- cen)
|
|
|
|
-- So, the idea is to attach outer children to the bottommost right nodes
|
|
-- inside an inner tree
|
|
roomMiniIntro :: RandomGen g => State g (Tree (Either Room Room))
|
|
roomMiniIntro = fmap (g . expandTreeBy f) $ sequence $ treePost
|
|
[return $ connectRoom door
|
|
,join $ takeOne [miniTree2,glassLesson]
|
|
-- ,join $ takeOne [miniRoom1]
|
|
]
|
|
$ randomiseLinks corridor
|
|
where f (Node (Right x) xs) = Node (Right (Right x)) $ map f xs
|
|
f (Node (Left x) xs) = Node (Left (Left x)) $ map f xs
|
|
g (Node (Right x) []) = Node (Right x) []
|
|
g (Node (Right x) xs) = Node (Left x) $ map g xs
|
|
g (Node y ys) = Node y $ map g ys
|
|
|
|
putSingleBlock :: Point2 -> [PlacementSpot]
|
|
putSingleBlock a = [PS a 0 $ PutBlock [5,20,20] (greyN 0.5)
|
|
$ reverse $ rectNSWE 10 (-10) (-10) 10]
|
|
|
|
putWallBlocks :: Point2 -> Point2 -> [PlacementSpot]
|
|
putWallBlocks a b = map (\p -> PS p rot $ PutBlockWall [5,20,20] (greyN 0.5)
|
|
$ reverse $ rectNSWE 10 (-10) (-10) 10)
|
|
ps
|
|
-- ++
|
|
-- map (\p -> PS p rot $ PutBlockWall [5,20,20] (greyN 0.5)
|
|
-- $ reverse $ rectNSWE 10 (-10) (-10) 10)
|
|
-- rs
|
|
|
|
where d = dist a b
|
|
rot = argV (b -.- a)
|
|
numPoints' = floor (d / 30)
|
|
numPoints = numPoints'*2 + 1
|
|
ns = take (numPoints + 1) [0..]
|
|
ps = map (\i -> a +.+ i/ (fromIntegral numPoints) *.* (b -.- a))
|
|
$ map fromIntegral ns
|
|
ps' = map (\i -> au +.+ i/ (fromIntegral numPoints) *.* (bu -.- au))
|
|
$ map fromIntegral ns
|
|
|
|
rs = map (\i -> ad +.+ i/ (fromIntegral numPoints) *.* (bd -.- ad))
|
|
$ map fromIntegral ns
|
|
norm = normalizeV $ vNormal $ b -.- a
|
|
au = a +.+ 10 *.* norm
|
|
bu = b +.+ 10 *.* norm
|
|
ad = a -.- 10 *.* norm
|
|
bd = b -.- 10 *.* norm
|
|
|
|
|
|
roomCenterPillar :: RandomGen g => State g Room
|
|
roomCenterPillar = changeLinkTo ((\p -> dist p (120,0) < 10) . fst)
|
|
$ set rmPS plmnts $ roomRect' 240 240 2 2
|
|
where plmnts = putWallBlocks (110,110) (110,130)
|
|
++ putWallBlocks (130,110) (130,130)
|
|
++ [PS (40,120) 0 basicLS
|
|
,PS (200,120) 0 basicLS
|
|
]
|
|
|
|
roomOctogon :: Room
|
|
roomOctogon = Room
|
|
{ _rmPolys = [[(-20,40),(20,40),(50,70),(50,110),(20,140),(-20,140),(-50,110),(-50,70)]
|
|
]
|
|
, _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)]
|
|
}
|
|
where lnks = [((0,140),0)
|
|
,((35,125),0-pi/4)
|
|
,((-35,125),pi/4)
|
|
,( (50,90),0-pi/2)
|
|
,( (-50,90),pi/2)
|
|
,((35,55),0-3*pi/4)
|
|
,((-35,55),3*pi/4)
|
|
,( (0,40),pi)
|
|
]
|
|
allPairs :: Eq a => [a] -> [(a,a)]
|
|
allPairs xs = [(x,y) | x <- xs, y <- xs, x /= y]
|
|
|
|
randomCorridorFrom :: RandomGen g => [a] -> State g (Tree (Either a a))
|
|
randomCorridorFrom xs = do
|
|
rooms <- sequence $ replicate 5 $ takeOne xs
|
|
return $ treeTrunk (map Left $ init rooms) (Node (Right (last rooms)) [])
|
|
|
|
|
|
randFirstWeapon :: State StdGen PSType
|
|
randFirstWeapon = do
|
|
r <- state $ randomR (-pi,pi)
|
|
takeOne $ map PutFlIt
|
|
[ basicFlIt {_flItRot=r,_flIt = pistol}
|
|
, basicFlIt {_flItRot=r,_flIt = ltAutoGun}
|
|
-- , basicFlIt {_flItRot=r,_flIt = autoGun}
|
|
, basicFlIt {_flItRot=r,_flIt = spreadGun}
|
|
, basicFlIt {_flItRot=r,_flIt = multGun}
|
|
, basicFlIt {_flItRot=r,_flIt = launcher}
|
|
-- , basicFlIt {_flItRot=r,_flIt = lasGun}
|
|
-- , basicFlIt {_flItRot=r,_flIt = flamer}
|
|
]
|
|
|
|
--randC1 :: State StdGen PSType
|
|
randC1 = RandPS $ takeOne $ map PutCrit $ (armourChaseCrit : replicate 50 chaseCrit)
|
|
|
|
randC = randC1
|
|
|
|
-- randSwarmCrit = RandPS $ takeOne $ map PutCrit $ (armouredSwarmCrit : replicate 100 swarmCrit)
|
|
|
|
weaponEmptyRoom :: RandomGen g => State g (Tree (Either Room Room))
|
|
weaponEmptyRoom = do
|
|
w <- state $ randomR (220,300)
|
|
h <- state $ randomR (220,300)
|
|
let plmnts = [PS (w/2,h-40) 0 $ RandPS randFirstWeapon
|
|
,PS (20,20) (pi/2) $ randC1
|
|
,PS (w-20,20) (pi/2) $ randC1
|
|
,PS (w/2,h/2) 0 $ basicLS
|
|
]
|
|
randomiseLinks =<< (changeLinkTo ((\p -> dist p (w/2,0) < 10) . fst)
|
|
$ set rmPS plmnts $ roomRect' w h 2 2)
|
|
|
|
|
|
--weaponUnderCrits :: RandomGen g => State g (Tree (Either Room Room))
|
|
--weaponUnderCrits = do
|
|
-- let plmnts = [PS (0,0) 0 $ RandPS randFirstWeapon
|
|
-- ,PS (-5,0) (0-pi/2) $ randC1
|
|
-- ,PS (5,20) (0-pi/2) $ randC1
|
|
-- ]
|
|
-- let continuationRoom = treeTrunk [Left corridorN,Left corridorN]
|
|
-- (connectRoom (set rmPS plmnts $ corridorN))
|
|
-- deadEndRoom <- takeOne [roomSquare,roomPillars,roomVs,roomCenterPillar]
|
|
-- junctionRoom <- takeOne [Left corridorE,Left corridorW]
|
|
-- return $ treeTrunk [Left corridorN,Left corridorN]
|
|
-- $ Node junctionRoom
|
|
-- [continuationRoom
|
|
-- ,deadRoom deadEndRoom
|
|
-- ]
|
|
|
|
|
|
weaponBehindPillar :: RandomGen g => State g (Tree (Either Room Room))
|
|
weaponBehindPillar = do
|
|
crPos <- takeOne $ [(x,y) | x <- [20,220], y <- [20,220]] ++ [(120,160),(120,200)]
|
|
let d p = argV $ (120,80) -.- p
|
|
let plmnts1 = [PS (120,160) 0 $ RandPS randFirstWeapon
|
|
,PS crPos (d crPos) $ randC1
|
|
]
|
|
rcp <- roomCenterPillar
|
|
return $ treeTrunk [Left door
|
|
,Left $ over rmLinks tail $ over rmPS (++ plmnts1) rcp]
|
|
(connectRoom $ set rmPS [PS (20,60) (0-pi/2) $ randC1]
|
|
$ corridorN)
|
|
|
|
weaponBetweenPillars :: RandomGen g => State g (Tree (Either Room Room))
|
|
weaponBetweenPillars = do
|
|
wpPos <- takeOne [(x,y) | x <- [20,120,220], y <- [20,120,220]]
|
|
(ps,_) <- takeNMore 2 ([], [(x,y) | x <- [20,220], y <- [20,120,220]])
|
|
let crPos1 = ps !! 0
|
|
let crPos2 = ps !! 1
|
|
let d p = argV $ (120,120) -.- p
|
|
let plmnts = [PS wpPos 0 $ RandPS randFirstWeapon
|
|
,PS crPos1 (d crPos1) $ randC1
|
|
,PS crPos2 (d crPos2) $ randC1
|
|
]
|
|
randomiseLinks =<< (filterLinks f $ over rmPS (++plmnts) $ roomPillars)
|
|
where f (_,a) = a == 0
|
|
|
|
blockedCorridor :: RandomGen g => State g (Tree (Either Room Room))
|
|
blockedCorridor = do
|
|
r <- state $ randomR (0,pi)
|
|
n <- state $ randomR (0,3)
|
|
let plmnts = [PS (20,40) r $ PutBlock [5,5,5] (150/256, 75/256, 0, 250/256)
|
|
$ reverse $ rectNSWE 10 (-10) (-10) 10
|
|
]
|
|
sequence $ treePost (replicate n $ fmap Left $ randLinks corridor)
|
|
$ fmap Right $ return $ set rmPS plmnts corridor
|
|
|
|
weaponLongCorridor :: RandomGen g => State g (Tree (Either Room Room))
|
|
weaponLongCorridor = do
|
|
root <- takeOne $ [tEast, tWest]
|
|
connectingRoom <- takeOne [tEast,tWest]
|
|
i1 <- state $ randomR (2,5)
|
|
i2 <- state $ randomR (2,5)
|
|
let branch1 = treeTrunk (replicate i1 $ Left corridor) (connectRoom $ putCrs connectingRoom)
|
|
let branch2 = treeTrunk (replicate i2 $ Left corridor) (deadRoom $ putWp corridorN)
|
|
return $ Node (Left $ addLS root) [branch1,branch2]
|
|
where putCrs = set rmPS [PS (10,40) (-pi/2) $ randC
|
|
,PS (-10,40) (-pi/2) $ randC
|
|
]
|
|
putWp = set rmPS [PS (20,40) 0 $ RandPS randFirstWeapon
|
|
,PS (20,60) 0 $ basicLS
|
|
]
|
|
addLS = id -- set rmPS [PS (0,60) 0 $ basicLS]
|
|
|
|
critInDeadEnd :: Room
|
|
critInDeadEnd = set rmPS [PS (0,0) 0 $ randC] deadEndRoom
|
|
|
|
deadEndRoom :: Room
|
|
deadEndRoom = Room
|
|
{ _rmPolys = [rectNSWE 40 (-20) (-20) 20
|
|
]
|
|
, _rmLinks = lnks
|
|
, _rmPath = []
|
|
, _rmPS = [PS (0,-10) 0 basicLS]
|
|
, _rmBound = rectNSWE 20 (-20) (-30) 30
|
|
}
|
|
where lnks = [((0,30) ,0)
|
|
]
|
|
|
|
|
|
weaponRoom :: RandomGen g => State g (Tree (Either Room Room))
|
|
weaponRoom = do
|
|
x <- takeOne [weaponEmptyRoom
|
|
--, weaponUnderCrits
|
|
, weaponBehindPillar
|
|
, weaponBetweenPillars
|
|
, weaponLongCorridor
|
|
]
|
|
x
|
|
|
|
roomCCrits :: RandomGen g => State g (Tree (Either Room Room))
|
|
roomCCrits = do
|
|
ps <- sequence $ replicate 25 $ randInCirc 9
|
|
let plmnts = map (\p -> PS p 0 $ randC)
|
|
$ zipWith (+.+) [(x,y) | x<-[110,130,150,170,190], y<- [70,90,110,130,150]] ps
|
|
return $ connectRoom $ over rmPS (++plmnts) $ roomC 200 200
|
|
|
|
branchRectWith :: RandomGen g => State g (Tree (Either Room Room)) -> State g (Tree (Either Room Room))
|
|
branchRectWith t = do
|
|
x <- state $ randomR (100,200)
|
|
y <- state $ randomR (100,200)
|
|
b <- t
|
|
root <- randLinks $ roomRect x y
|
|
return $ Node (Left root) [Node (Right door) [], fmap rToL $ treeTrunk [Left door] b]
|
|
where rToL :: Either a a -> Either a a
|
|
rToL (Right r) = Left r
|
|
rToL (Left r) = Left r
|
|
|
|
slowDoorRoom :: RandomGen g => State g (Tree (Either Room Room))
|
|
slowDoorRoom = do
|
|
x <- state $ randomR (400,800)
|
|
y <- state $ randomR (400,800)
|
|
h <- state $ randomR (200,min (y-100) 500)
|
|
(butPos,butRot) <- takeOne [( (x/2-50,5),0)
|
|
,( (x/2+50,5),0)
|
|
]
|
|
let n = 25
|
|
xs <- sequence $ replicate n $ state $ randomR (10,x-10)
|
|
ys <- sequence $ replicate n $ state $ randomR (h+20,y)
|
|
rs <- sequence $ replicate n $ state $ randomR (0,2*pi)
|
|
let ps = zip xs ys
|
|
xs' <- sequence $ replicate 5 $ state $ randomR (10,x-10)
|
|
ys' <- sequence $ replicate 5 $ state $ randomR (h+20,y)
|
|
let crits = zipWith (\p r -> PS p r randC1) ps rs
|
|
lsources = [PS (x/2,30) 0 basicLS, PS (x/2,y-30) 0 basicLS]
|
|
let barrels = zipWith (\x y -> PS (x,y) 0 $ PutCrit explosiveBarrel) xs' ys'
|
|
let pillarsa = []
|
|
let pillarsb = putBlockRect (x/5-20) (x/5+20) (h/2-20) (h/2+20)
|
|
++ putBlockRect (2*x/5-20) (2*x/5+20) (h/2-20) (h/2+20)
|
|
++ putBlockRect (3*x/5-20) (3*x/5+20) (h/2-20) (h/2+20)
|
|
++ putBlockRect (4*x/5-20) (4*x/5+20) (h/2-20) (h/2+20)
|
|
let pillarsc = putBlockRect (x/3-20) (x/3+20) (h/2-20) (h/2+20)
|
|
++ putBlockRect (2*x/3-20) (2*x/3+20) (h/2-20) (h/2+20)
|
|
pillars <- takeOne [pillarsa, pillarsb, pillarsc]
|
|
let cond x = (snd . fst) x > h + 40
|
|
let cond2 x = (snd . fst) x < h - 40
|
|
but <- takeOne [PutBtDoor (dim $ light red) butPos butRot (0,h) (x,h)
|
|
-- ,PutSwitchDoor (dim $ light red) butPos butRot (0,h) (x,h)
|
|
]
|
|
fmap connectRoom (filterLinks cond =<< (changeLinkTo cond2
|
|
$ set rmPS ([PS (0,0) 0 but] ++ crits ++ pillars ++ barrels ++ lsources)
|
|
$ roomRect x y
|
|
))
|
|
longRoom :: RandomGen g => State g Room
|
|
longRoom = do
|
|
h <- state $ randomR (1500,1500)
|
|
let w = 75
|
|
let cond x = (snd . fst) x < h - 40
|
|
let ws = map (\ps -> PS (0,0) 0 $ PutWindow ps $ withAlpha 0.5 aquamarine)
|
|
[rectNSWE (h-35) (h-135) (-10) 10
|
|
,rectNSWE (h-35) (h-135) 15 35
|
|
,rectNSWE (h-35) (h-135) 40 60
|
|
,rectNSWE (h-35) (h-135) 65 85
|
|
]
|
|
let wsDefense = map (\ps -> PS (0,0) 0 $ PutWindow ps $ withAlpha 0.5 aquamarine)
|
|
[rectNSWE (95) (70) 0 25
|
|
,rectNSWE (95) (70) 50 75
|
|
]
|
|
brls <- fmap (map (\p -> PS (p +.+ (10,200)) 0 $ PutCrit explosiveBarrel) )
|
|
$ sequence $ replicate 5 $ randInRect (w-20) 900
|
|
let rm = roomRect' w (h+70) 1 1 & rmPolys %~ ( (++)
|
|
[rectNSWE h (h-165) (-45) (w+45)
|
|
]
|
|
)
|
|
changeLinkTo cond $ set rmPS (ws ++ brls ++ wsDefense ++
|
|
[PS ( 12.5,h-25) 0 $ PutCrit longCrit
|
|
,PS ( 37.5,h-25) 0 $ PutCrit longCrit
|
|
,PS ( 62.5,h-25) 0 $ PutCrit longCrit
|
|
,PS ( 25, 20) 0 $ basicLS
|
|
,PS ( 25, h-10) 0 $ basicLS
|
|
]
|
|
)
|
|
$ rm
|
|
|
|
|
|
shooterRoom :: RandomGen g => State g Room
|
|
shooterRoom = do
|
|
h <- state $ randomR (200,300)
|
|
let cond x = (snd . fst) x < h - 40
|
|
changeLinkTo cond $ set rmPS ( putWallBlocks (50,50) (50,h) ++
|
|
[PS ( 25,h-25) 0 $ PutCrit $ addArmour autoCrit
|
|
,PS ( 75,h-30) 0 $ PutCrit explosiveBarrel
|
|
,PS ( 75,h-60) 0 $ PutCrit explosiveBarrel
|
|
,PS ( 85,h-10) 0 $ PutCrit explosiveBarrel
|
|
,PS ( 85,h-45) 0 $ PutCrit explosiveBarrel
|
|
,PS ( 75,h-80) 0 basicLS
|
|
]
|
|
)
|
|
$ roomRect' 100 h 1 1
|
|
|
|
|
|
shootersRoom1 :: RandomGen g => State g Room
|
|
shootersRoom1 = do
|
|
w <- state $ randomR (200,300)
|
|
x1 <- state $ randomR (20,w/3-20)
|
|
x2 <- state $ randomR (w/3+20,2*w/3-20)
|
|
x3 <- state $ randomR (2*w/3+20,w-20)
|
|
y1 <- state $ randomR (250,560)
|
|
y2 <- state $ randomR (250,560)
|
|
y3 <- iterateWhile (\y' -> abs (y1 - y2) < 60 && abs (y2 - y') < 60) $ state $ randomR (250,560)
|
|
x4 <- state $ randomR (60,w-60)
|
|
y4 <- state $ randomR (40,180)
|
|
p <- takeOne [(x1,y1-10),(x2,y2-10),(x3,y3-10)]
|
|
let bln x y = putBlockN (x+25) (x-25) (y+10) (y)
|
|
let blv x y = putBlockV (x+25) (x-25) (y+10) (y)
|
|
let plmnts = bln x1 y1 ++ bln x2 y2 ++ bln x3 y3 ++ blv x4 y4
|
|
++ [PS p (-pi/2) $ PutCrit autoCrit
|
|
,PS (w/2,200) 0 basicLS
|
|
]
|
|
return $ set rmPS plmnts $ roomRect w 600
|
|
|
|
shootersRoom :: RandomGen g => State g Room
|
|
shootersRoom = do
|
|
w <- state $ randomR (200,300)
|
|
x1 <- state $ randomR (20,w/3-20)
|
|
x2 <- state $ randomR (w/3+20,2*w/3-20)
|
|
x3 <- state $ randomR (2*w/3+20,w-20)
|
|
y1 <- state $ randomR (250,560)
|
|
y2 <- state $ randomR (250,560)
|
|
y3 <- iterateWhile (\y' -> abs (y1 - y2) < 60 && abs (y2 - y') < 60) $ state $ randomR (250,560)
|
|
x4 <- state $ randomR (60,w-60)
|
|
y4 <- state $ randomR (40,180)
|
|
let bln x y = putBlockN (x+25) (x-25) (y+10) (y)
|
|
let blv x y = putBlockV (x+25) (x-25) (y+10) (y)
|
|
let plmnts = bln x1 y1 ++ bln x2 y2 ++ bln x3 y3 ++ blv x4 y4
|
|
++ [PS (x1,y1-10) (-pi/2) $ PutCrit autoCrit
|
|
,PS (x2,y2-10) (-pi/2) $ PutCrit autoCrit
|
|
,PS (x3,y3-10) (-pi/2) $ PutCrit autoCrit
|
|
,PS (w/2,200) 0 basicLS
|
|
]
|
|
return $ set rmPS plmnts $ roomRect w 600
|
|
|
|
pistolerRoom :: RandomGen g => State g Room
|
|
pistolerRoom = do
|
|
let f2 x y = putSingleBlock (x,y)
|
|
-- let f2 x y = [PS (x,y) 0 $ PutWindow (rectNSEW 40 0 0 40) $ withAlpha 0.5 aquamarine]
|
|
f3 x y = putWallBlocks (x-20,y) (x+20,y)
|
|
++ putWallBlocks (x,y-20) (x,y+20)
|
|
f4 x y = putWallBlocks (x-20,y-20) (x+20,y+20)
|
|
++ putWallBlocks (x+20,y-20) (x-20,y+20)
|
|
--f <- takeOne [f2,f3,f4]
|
|
f <- takeOne [f2]
|
|
h <- state $ randomR (400,800)
|
|
let w = h
|
|
i <- takeOne [4,6,8]
|
|
let j = fromIntegral (i+1)
|
|
-- the 20+etc here is to correct for the pathfinding grid, which matches up to
|
|
-- edges based on the size of doors (i.e. the line next to the wall is 20
|
|
-- away from it)
|
|
xs = take i [20+0.5*(w-40)/(j-1),20+1.5*(w-40)/(j-1)..]
|
|
ys = take i [20+0.5*(h-40)/(j-1),20+1.5*(h-40)/(j-1)..]
|
|
gap = 0.5 * h / j
|
|
ps <- takeN 3 $ zip (map (+gap) xs) ys
|
|
aa <- state $ randomR (0,2*pi)
|
|
ab <- state $ randomR (0,2*pi)
|
|
ac <- state $ randomR (0,2*pi)
|
|
let plmnts = [PS (ps !! 0) aa $ PutCrit pistolCrit
|
|
,PS (ps !! 1) ab $ PutCrit pistolCrit
|
|
,PS (ps !! 2) ac $ PutCrit pistolCrit
|
|
-- ,PS (w-5,h/2) 0 $ basicLS
|
|
-- ,PS (5,h/2) 0 $ basicLS
|
|
-- ,PS (w/2,h-5) 0 $ basicLS
|
|
-- ,PS (w/2,5) 0 $ basicLS
|
|
-- ,PS (w-50,h/2) 0 $ basicLS
|
|
-- ,PS (50,h/2) 0 $ basicLS
|
|
,PS (w/2,h-50) 0 $ basicLS
|
|
,PS (w/2,50) 0 $ basicLS
|
|
,PS (w-5,h-5) 0 $ basicLS
|
|
,PS (5,h-5) 0 $ basicLS
|
|
,PS (w-5,5) 0 $ basicLS
|
|
,PS (5,5) 0 $ basicLS
|
|
,PS (w/2,h/2) 0 $ basicLS
|
|
]
|
|
++
|
|
-- f (w*0.25) (h*0.5)
|
|
concat [f x y | x<-xs,y<-ys]
|
|
return
|
|
$ set rmPS plmnts $ roomRect' w h (max i 2) (max i 2)
|
|
|
|
shootingRange :: RandomGen g => State g (Tree (Either Room Room))
|
|
shootingRange = do
|
|
rm1 <- shootersRoom1 >>= changeLinkTo (\((_,y),_) -> y < 40)
|
|
>>= filterLinks (\((_,y),r) -> y > 200 && r /= 0)
|
|
rm2 <- shootersRoom >>= changeLinkTo (\((x,y),_) -> y < 10 && x > 20 && x < 180)
|
|
>>= filterLinks (\((_,y),r) -> y > 200 && r /= 0)
|
|
rm3 <- shootersRoom >>= changeLinkTo (\((x,y),_) -> y < 10 && x > 20 && x < 180)
|
|
>>= filterLinks (\(_,r) -> r == 0)
|
|
return $ treePost [Left rm1
|
|
,Left $ roomPadCut (rectNSWE 20 (-20) (-80) 80) (0,20)
|
|
,Left rm2
|
|
,Left $ roomPadCut (rectNSWE 20 (-20) (-80) 80) (0,20)
|
|
]
|
|
(Right rm3)
|
|
|
|
spawnerRoom :: RandomGen g => State g (Tree (Either Room Room))
|
|
spawnerRoom = do
|
|
x <- state $ randomR (250,300)
|
|
y <- state $ randomR (300,400)
|
|
wl <- takeOne [PS (0,0) 0 $ PutWindow (rectNSWE (y-60) 0 (x/2-10) (x/2+10))
|
|
$ withAlpha 0.5 aquamarine
|
|
,PS (0,0) 0 $ PutWindowBlock (x/2,0) (x/2,y-60)
|
|
]
|
|
let plmnts = [PS (x/4, y/4) (pi/2) $ PutCrit spawnerCrit
|
|
-- ,PS (0,0) 0 $ PutWindowBlock (x/2,0) (x/2,y-60)
|
|
,wl
|
|
,PS (x/2, y-10) 0 basicLS
|
|
]
|
|
let f ((lx,_),_) = lx < x/2-5
|
|
roomWithSpawner <- randomiseLinks =<< (filterLinks f $ set rmPS plmnts $ roomRect' x y 2 2)
|
|
return $ treeTrunk [Left (airlock 0)] roomWithSpawner
|