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

Add support for group placements

Browse Source
This commit is contained in:
jgk
2021-05-14 19:46:52 +02:00
parent 0b26761be5
commit 2b09bf2072
18 changed files with 307 additions and 266 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Creature.hs
+1 -1
View File
@@ -279,7 +279,7 @@ startInventory = IM.fromList (zip [0..20]
,lasGun
,autoGun
--,poisonSprayer
--,launcher
,launcher
--,lasGun
--,grenade
--,ltAutoGun,flamer,multGun,spreadGun,remoteLauncher
src/Dodge/Floor.hs
+2 -1
View File
@@ -30,6 +30,7 @@ import Dodge.SoundLogic
import Dodge.RandomHelp
import Dodge.LightSources
import Dodge.LevelGen.Data
import Dodge.LevelGen.SwarmPlacement
import Dodge.Item.Weapon
import Data.Tree
@@ -50,7 +51,7 @@ roomTreex = do
[[StartRoom]
,[Corridor]
,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400
& rmPS %~ (PS (0,200) 0 (PutCrit spreadGunCrit) :)
& rmPS %~ ([swarmPS 0 (x,y) 0 smallChaseCrit | x <- [-20,-19.5.. 20] , y <- [200,200.5..202] ]++)
]
,[Corridor]
,[Corridor]
src/Dodge/LevelGen.hs
+66 -52
View File
@@ -37,56 +37,66 @@ import qualified Data.Set as S
import qualified Data.Map as M
placeSpots :: [PlacementSpot] -> World -> World
placeSpots pss w = foldr placeSpot w pss
placeSpots :: [Placement] -> World -> World
placeSpots pss w = foldr placeSpot w' $ map _placementSpot singlePlacements
where
(singlePlacements, groupedPlacements) = partition isSPS pss
isSPS (SinglePlacement {}) = True
isSPS _ = False
gplmnts = groupBy ((==) `on` _groupPlacementID) $ sortOn _groupPlacementID groupedPlacements
w' = foldr updateGroup w gplmnts
{- | OK, this is perhaps slightly impenetrable.
- The idea is that for a list of collected group placements, we first update
- the world for each placement and update the placements into PSTypes.
- This is the mapAccumR step.
- After this, for each placement we apply the group placement function to
- the psType using a zipWith, and taking all the pstypes as a paramenter,
- then successively update the world using a foldr. -}
updateGroup :: [Placement] -> World -> World
updateGroup ps w =
let (w', psTypes) = mapAccumR updateSpot w $ map _placementSpot ps
fs = zipWith (\gp pst -> _groupPlacementFunc gp psTypes pst) ps psTypes
in foldr ($) w' fs
updateSpot :: World -> PlacementSpot -> (World, PSType)
updateSpot w ps = case _psType ps of
PutButton bt -> undefined
PutCrit cr -> placeUpdateCr cr p rot w
where
p = _psPos ps
rot = _psRot ps
placeSpot :: PlacementSpot -> World -> World
placeSpot ps w = case ps of
PS {_psPos = p, _psRot = rot, _psType = PutButton bt}
-> placeBt bt p rot w
PS {_psPos = p, _psRot = rot, _psType = PutFlIt itm}
-> placeFlIt itm p rot w
PS {_psPos = p, _psRot = rot, _psType = PutCrit cr}
-> placeCr cr p rot w
PS {_psPos = p, _psRot = rot, _psType = PutLS ls dec}
-> placeLS ls dec p rot w
PS {_psPos = p, _psRot = rot, _psType = PutPressPlate pp}
-> placePressPlate pp p rot w
PS {_psType = RandPS rgen}
-> placeSpot (set psType evaluatedType ps) (set randGen g w)
placeSpot ps w = case _psType ps of
PutButton bt -> placeBt bt p rot w
PutFlIt itm -> placeFlIt itm p rot w
PutCrit cr -> placeCr cr p rot w
PutLS ls dec -> placeLS ls dec p rot w
PutPressPlate pp -> placePressPlate pp p rot w
RandPS rgen -> placeSpot (set psType evaluatedType ps) (set randGen g w)
where
(evaluatedType, g) = runState rgen (_randGen w)
PS {_psPos = p, _psRot = rot, _psType = PutDoor col f pss}
-> putDoor col f (map (mapBoth $ shiftPointBy (p,rot)) pss) w
(evaluatedType, g) = runState rgen (_randGen w)
PutDoor col f pss -> putDoor col f (map (mapBoth $ shiftPointBy (p,rot)) pss) w
where
mapBoth fn (x,y) = (fn x, fn y)
PS {_psPos = p, _psRot = rot, _psType = PutDoubleDoor col f a b}
-> putDoubleDoor col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
PS {_psPos = p, _psRot = rot, _psType = PutAutoDoor a b}
-> addAutoDoor (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
PS {_psPos = p, _psRot = rot, _psType = PutBlock (hp:hps) col ps}
-> putBlock (map (shiftPointBy (p,rot)) ps) hp col False hps w
PS {_psPos = p, _psRot = rot, _psType = PutBtDoor c bp f a b}
-> addButtonDoor c (shiftPointBy (p,rot) bp) (f + rot)
PutDoubleDoor col f a b -> putDoubleDoor col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
PutAutoDoor a b -> addAutoDoor (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
PutBlock (hp:hps) col ps -> putBlock (map (shiftPointBy (p,rot)) ps) hp col False hps w
PutBtDoor c bp f a b -> addButtonDoor c (shiftPointBy (p,rot) bp) (f + rot)
(shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
PS {_psPos = p, _psRot = rot, _psType = PutSwitchDoor c bp f a b}
-> addSwitchDoor c (shiftPointBy (p,rot) bp) (f + rot)
PutSwitchDoor c bp f a b -> addSwitchDoor c (shiftPointBy (p,rot) bp) (f + rot)
(shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
PS {_psPos = p, _psRot = rot, _psType = PutLineBlock wl width depth a b}
PutLineBlock wl width depth a b
-> putLineBlock wl width depth (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
PS {_psPos = p, _psRot = rot, _psType = PutWall { _pwPoly = ps, _pwWall = wl }}
-> rmCrossPaths $ over walls (addWalls (q:qs) wl) w
where (q:qs) = map (shiftPointBy (p,rot)) ps
rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ zip (q:qs) (qs++[q])
PutWall { _pwPoly = ps, _pwWall = wl } -> rmCrossPaths $ over walls (addWalls (q:qs) wl) w
where
(q:qs) = map (shiftPointBy (p,rot)) ps
rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ zip (q:qs) (qs++[q])
_ -> w
where
p = _psPos ps
rot = _psRot ps
-- TODO: remove this typeclass
class Shiftable a where
@@ -109,7 +119,6 @@ instance Shiftable PlacementSpot where
translateS p' (PS p r x) = PS (p +.+ p') r x
rotateS r' (PS p r x) = PS (rotateV r' p) (r + r') x
shiftPointBy (pos,rot) p = pos +.+ rotateV rot p
addWalls :: [Point2] -> Wall -> IM.IntMap Wall -> IM.IntMap Wall
@@ -117,6 +126,7 @@ addWalls qs wl wls = foldr (addPane wl) wls pairs
where
(p:ps) = orderPolygon qs
pairs = zip (ps ++ [p]) (p:ps)
addPane :: Wall -> (Point2,Point2) -> IM.IntMap Wall -> IM.IntMap Wall
addPane wl (p0,p1) wls = IM.insert (newKey wls) (wl
{ _wlLine = (p0,p1)
@@ -124,15 +134,11 @@ addPane wl (p0,p1) wls = IM.insert (newKey wls) (wl
})
wls
placeBt bt p rot w = over buttons addBT w
where
addBT bts = IM.insert (newKey bts) (bt {_btPos = p, _btRot = rot, _btID = newKey bts}) bts
{-
Creates a floor item at a given point.
Assigns an id correctly.
-}
{- Creates a floor item at a given point.
Assigns an id correctly. -}
placeFlIt
:: Item
-> Point2 -- ^ Position
@@ -150,13 +156,21 @@ placeFlIt itm p rot = floorItems %~
) fis
placePressPlate pp p rot w = over pressPlates addPP w
where addPP pps = IM.insert (newKey pps) (pp {_ppPos = p,_ppRot = rot}) pps
where
addPP pps = IM.insert (newKey pps) (pp {_ppPos = p,_ppRot = rot}) pps
placeUpdateCr :: Creature -> Point2 -> Float -> World -> (World, PSType)
placeUpdateCr scr p rot w = (w & creatures %~ IM.insert cid cr, PutCrit cr)
where
cid = newKey (_creatures w)
cr = scr {_crPos = p,_crOldPos = p,_crDir = rot,_crID = cid}
placeCr :: Creature -> Point2 -> Float -> World -> World
placeCr crF p rot w = over creatures addCr w
where addCr crs = IM.insert (newKey crs)
(crF {_crPos = p,_crOldPos = p,_crDir = rot,_crID = newKey crs})
crs
where
addCr crs = IM.insert (newKey crs)
(crF {_crPos = p,_crOldPos = p,_crDir = rot,_crID = newKey crs})
crs
placeLS :: LightSource -> Picture -> Point2 -> Float -> World -> World
placeLS ls dec p rot w = over lightSources addLS
src/Dodge/LevelGen/Data.hs
+4 -2
View File
@@ -9,7 +9,7 @@ import Control.Lens
import Control.Monad.State
import System.Random
data PSType = PutCrit Creature
data PSType = PutCrit {_unPutCrit :: Creature}
| PutLS LightSource Picture
| PutButton Button
| PutFlIt Item
@@ -34,10 +34,12 @@ data Placement
= SinglePlacement {_placementSpot :: PlacementSpot }
| GroupedPlacement
{_groupPlacementID :: Int
,_groupPlacementFunc :: [PlacementSpot] -> PlacementSpot -> PlacementSpot
,_groupPlacementFunc :: [PSType] -> PSType -> World -> World
,_placementSpot :: PlacementSpot
}
sPS p a = SinglePlacement . PS p a
makeLenses ''PSType
makeLenses ''PlacementSpot
makeLenses ''Placement
src/Dodge/LevelGen/SwarmPlacement.hs
+25
View File
@@ -0,0 +1,25 @@
module Dodge.LevelGen.SwarmPlacement
( swarmPS
)
where
import Dodge.Data
import Dodge.LevelGen.Data
import Dodge.Creature.State.Data
import qualified Data.Set as S
import Control.Lens
swarmPS :: Int -> Point2 -> Float -> Creature -> Placement
swarmPS i p a cr = GroupedPlacement
{ _groupPlacementID = i
, _groupPlacementFunc = setSwarm
, _placementSpot = PS p a $ PutCrit cr
}
setSwarm :: [PSType] -> PSType -> World -> World
setSwarm psts (PutCrit cr) w
= w & creatures . ix cid . crGroup .~ theSwarm
where
cid = _crID cr
theSwarm = Swarm swarmSet
swarmSet = S.fromList $ map (_crID . _unPutCrit) psts
src/Dodge/Room.hs
+89 -89
View File
@@ -77,9 +77,9 @@ roomPadCut ps p = Room
roomPillars :: Room
roomPillars = over rmLinks init $ set rmPS plmnts $ roomRect 240 240 2 2
where
plmnts = PS (120,120) 0 putLamp
: PS (12,12) 0 putLamp
: PS (228,228) 0 putLamp
plmnts = sPS (120,120) 0 putLamp
: sPS (12,12) 0 putLamp
: sPS (228,228) 0 putLamp
: g 180 150 90 60
f a x b y = putBlockRect a x b y
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
@@ -103,7 +103,7 @@ glassSwitchBack = do
,blockLine (wth-wllen, 2*hf) ( wth,2*hf)
,blockLine ( 0, 3*hf) (wllen,3*hf)
,blockLine (wth-wllen, 4*hf) ( wth,4*hf)
, PS (wth/2,hgt/2) 0 $ putLamp
, sPS (wth/2,hgt/2) 0 $ putLamp
]
return $ set rmPS plmnts $ roomRect wth hgt 2 6
@@ -119,14 +119,14 @@ glassLesson = do
$ roomRect 200 200 1 1
topRoom = set rmPS topplmnts
$ roomRect 200 200 1 1
botplmnts = [PS (0,0) 0 $ PutWall (rectNSWE (200) 0 (90) (110))
botplmnts = [sPS (0,0) 0 $ PutWall (rectNSWE (200) 0 (90) (110))
$ defaultCrystalWall
,PS (50,100) 0 $ PutCrit miniGunCrit
,PS (50,50) 0 putLamp
,sPS (50,100) 0 $ PutCrit miniGunCrit
,sPS (50,50) 0 putLamp
]
topplmnts = [windowLine (100,200) (100,0)
,PS (50,100) 0 $ PutCrit miniGunCrit
,PS (50,50) 0 putLamp
,sPS (50,100) 0 $ PutCrit miniGunCrit
,sPS (50,50) 0 putLamp
]
miniRoom1 :: RandomGen g => State g Room
@@ -144,9 +144,9 @@ miniRoom1 = do
,windowLine (wth-wllen,40+2*hf) (60,40+2*hf)
,windowLine (wth-60, 40+3*hf) (wllen,40+3*hf)
,windowLine (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 putLamp
,sPS (crx,cry) 0 $ PutCrit miniGunCrit
,sPS (wth-20,hgt/2+40) 0 $ randC
,sPS (wth/2,hgt/2) 0 putLamp
,blockLine ( 0, 40+1*hf) (wllen,40+1*hf)
,blockLine (wth-wllen, 40+2*hf) ( wth,40+2*hf)
,blockLine ( 0, 40+3*hf) (wllen,40+3*hf)
@@ -169,24 +169,24 @@ miniRoom3 = do
,( 10,-80)
,(-10,-80)
]
let plmnts = [PS cp 0 $ PutCrit miniGunCrit
,PS cp 0 $ windowLineType (0,-40) (0,-80)
,PS cp (1*pi/4) $ windowLineType (0,-40) (0,-80)
,PS cp (2*pi/4) $ windowLineType (0,-40) (0,-80)
,PS cp (3*pi/4) $ windowLineType (0,-40) (0,-80)
,PS cp (4*pi/4) $ windowLineType (0,-40) (0,-80)
,PS cp (5*pi/4) $ windowLineType (0,-40) (0,-80)
,PS cp (6*pi/4) $ windowLineType (0,-40) (0,-80)
,PS cp (7*pi/4) $ windowLineType (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 putLamp
let plmnts = [sPS cp 0 $ PutCrit miniGunCrit
,sPS cp 0 $ windowLineType (0,-40) (0,-80)
,sPS cp (1*pi/4) $ windowLineType (0,-40) (0,-80)
,sPS cp (2*pi/4) $ windowLineType (0,-40) (0,-80)
,sPS cp (3*pi/4) $ windowLineType (0,-40) (0,-80)
,sPS cp (4*pi/4) $ windowLineType (0,-40) (0,-80)
,sPS cp (5*pi/4) $ windowLineType (0,-40) (0,-80)
,sPS cp (6*pi/4) $ windowLineType (0,-40) (0,-80)
,sPS cp (7*pi/4) $ windowLineType (0,-40) (0,-80)
,sPS cp (pi/8) b
,sPS cp (pi/8+1*pi/4) b
,sPS cp (pi/8+2*pi/4) b
,sPS cp (pi/8+3*pi/4) b
,sPS cp (pi/8+4*pi/4) b
,sPS cp (pi/8+5*pi/4) b
,sPS cp (pi/8+6*pi/4) b
,sPS cp (pi/8+7*pi/4) b
,sPS (w/2,h/2) 0 putLamp
]
fmap connectRoom $ randomiseOutLinks $ set rmPS plmnts $ roomRectAutoLinks w h
@@ -215,8 +215,8 @@ roomCenterPillar = changeLinkTo ((\p -> dist p (120,0) < 10) . fst)
plmnts =
[ blockLine (115,115) (115,125)
, blockLine (125,115) (125,125)
, PS (40,120) 0 putLamp
, PS (200,120) 0 putLamp
, sPS (40,120) 0 putLamp
, sPS (200,120) 0 putLamp
]
roomOctogon :: Room
@@ -264,10 +264,10 @@ 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 $ putLamp
let plmnts = [sPS (w/2,h-40) 0 $ RandPS randFirstWeapon
,sPS (20,20) (pi/2) $ randC1
,sPS (w-20,20) (pi/2) $ randC1
,sPS (w/2,h/2) 0 $ putLamp
]
(fmap connectRoom . randomiseOutLinks) =<< (changeLinkTo ((\p -> dist p (w/2,0) < 10) . fst)
$ set rmPS plmnts $ roomRect w h 2 2)
@@ -275,14 +275,14 @@ weaponEmptyRoom = do
weaponUnderCrits :: RandomGen g => State g (Tree (Either Room Room))
weaponUnderCrits = do
let plmnts =
[PS (20,0) 0 $ RandPS randFirstWeapon
,PS (20,0) (0-pi/2) $ randC1
,PS (20,20) (0-pi/2) $ randC1
[sPS (20,0) 0 $ RandPS randFirstWeapon
,sPS (20,0) (0-pi/2) $ randC1
,sPS (20,20) (0-pi/2) $ randC1
]
let continuationRoom = treeFromTrunk [Left corridorN,Left corridorN]
(connectRoom (set rmPS plmnts $ corridorN))
rcp' <- roomCenterPillar
let rcp = over rmPS ( PS (120,80) 0 putLamp : ) rcp'
let rcp = over rmPS ( sPS (120,80) 0 putLamp : ) rcp'
deadEndRoom <- takeOne [roomPillars,rcp]
junctionRoom <- takeOne [Left tEast,Left tWest]
return $ treeFromTrunk [Left corridorN,Left corridorN]
@@ -295,13 +295,13 @@ 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
let plmnts1 = [sPS (120,160) 0 $ RandPS randFirstWeapon
,sPS crPos (d crPos) $ randC1
]
rcp <- roomCenterPillar
return $ treeFromTrunk [Left door
,Left $ over rmLinks tail $ over rmPS (++ plmnts1) rcp]
(connectRoom $ set rmPS [PS (20,60) (0-pi/2) $ randC1]
(connectRoom $ set rmPS [sPS (20,60) (0-pi/2) $ randC1]
$ corridorN)
weaponBetweenPillars :: RandomGen g => State g (Tree (Either Room Room))
@@ -312,9 +312,9 @@ weaponBetweenPillars = do
crPos2 = ps !! 1
d p = argV $ (120,120) -.- p
plmnts =
[PS wpPos 0 $ RandPS randFirstWeapon
,PS crPos1 (d crPos1) $ randC1
,PS crPos2 (d crPos2) $ randC1
[sPS wpPos 0 $ RandPS randFirstWeapon
,sPS crPos1 (d crPos1) $ randC1
,sPS crPos2 (d crPos2) $ randC1
]
(fmap connectRoom . randomiseOutLinks) =<< (filterLinks f $ over rmPS (++plmnts) $ roomPillars)
where
@@ -324,23 +324,23 @@ weaponLongCorridor :: RandomGen g => State g (Tree (Either Room Room))
weaponLongCorridor = do
root <- takeOne $ [tEast, tWest]
connectingRoom <- takeOne
[tEast & rmPS .~ [PS (-40,60) 0 $ putLamp]
,tWest & rmPS .~ [PS ( 40,60) 0 $ putLamp]
[tEast & rmPS .~ [sPS (-40,60) 0 $ putLamp]
,tWest & rmPS .~ [sPS ( 40,60) 0 $ putLamp]
]
i1 <- state $ randomR (2,5)
i2 <- state $ randomR (2,5)
let branch1 = treeFromTrunk (replicate i1 $ Left corridorN) (connectRoom $ putCrs connectingRoom)
let branch2 = treeFromTrunk (replicate i2 $ Left corridorN) (deadRoom $ putWp corridor)
return $ Node (Left root) [branch1,branch2]
where putCrs = over rmPS (++ [PS (10,40) (-pi/2) $ randC
,PS (-10,40) (-pi/2) $ randC
where putCrs = over rmPS (++ [sPS (10,40) (-pi/2) $ randC
,sPS (-10,40) (-pi/2) $ randC
])
putWp = set rmPS [PS (20,40) 0 $ RandPS randFirstWeapon
,PS (20,60) 0 $ putLamp
putWp = set rmPS [sPS (20,40) 0 $ RandPS randFirstWeapon
,sPS (20,60) 0 $ putLamp
]
critInDeadEnd :: Room
critInDeadEnd = set rmPS [PS (0,0) 0 $ randC] deadEndRoom
critInDeadEnd = set rmPS [sPS (0,0) 0 $ randC] deadEndRoom
deadEndRoom :: Room
deadEndRoom = Room
@@ -348,7 +348,7 @@ deadEndRoom = Room
]
, _rmLinks = lnks
, _rmPath = []
, _rmPS = [PS (0,-10) 0 putLamp]
, _rmPS = [sPS (0,-10) 0 putLamp]
, _rmBound = [rectNSWE 20 (-20) (-30) 30]
}
where
@@ -366,9 +366,9 @@ weaponRoom = join $ takeOne
roomCCrits :: RandomGen g => State g (Tree (Either Room Room))
roomCCrits = do
ps <- sequence $ replicate 20 $ randInCirc 9
let plmnts = map (\p -> PS p 0 $ randC)
let plmnts = map (\p -> sPS p 0 $ randC)
$ zipWith (+.+) [(x,y) | x<-[110,130,150,170,190], y<- [70,90,110,130,150]] ps
lamps = [PS (50,100) 0 putLamp , PS (175,100) 0 putLamp]
lamps = [sPS (50,100) 0 putLamp , sPS (175,100) 0 putLamp]
return $ connectRoom $ over rmPS ((lamps ++) . (plmnts ++)) $ roomC 200 200
@@ -377,25 +377,25 @@ 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 $ PutWall ps defaultCrystalWall)
let ws = map (\ps -> sPS (0,0) 0 $ PutWall ps defaultCrystalWall)
[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 $ PutWall ps defaultCrystalWall)
let wsDefense = map (\ps -> sPS (0,0) 0 $ PutWall ps defaultCrystalWall)
[rectNSWE (95) (70) 0 25
,rectNSWE (95) (70) 50 75
]
brls <- fmap (map (\p -> PS (p +.+ (10,200)) 0 $ PutCrit explosiveBarrel) )
brls <- fmap (map (\p -> sPS (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 $ putLamp
,PS ( 25, h-10) 0 $ putLamp
[sPS ( 12.5,h-25) 0 $ PutCrit longCrit
,sPS ( 37.5,h-25) 0 $ PutCrit longCrit
,sPS ( 62.5,h-25) 0 $ PutCrit longCrit
,sPS ( 25, 20) 0 $ putLamp
,sPS ( 25, h-10) 0 $ putLamp
]
)
$ rm
@@ -406,12 +406,12 @@ shooterRoom = do
h <- state $ randomR (200,300)
let cond x = (snd . fst) x < h - 40
changeLinkTo cond $ set rmPS ( [blockLine (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 putLamp
,sPS ( 25,h-25) 0 $ PutCrit $ addArmour autoCrit
,sPS ( 75,h-30) 0 $ PutCrit explosiveBarrel
,sPS ( 75,h-60) 0 $ PutCrit explosiveBarrel
,sPS ( 85,h-10) 0 $ PutCrit explosiveBarrel
,sPS ( 85,h-45) 0 $ PutCrit explosiveBarrel
,sPS ( 75,h-80) 0 putLamp
]
)
$ roomRect 100 h 1 1
@@ -432,8 +432,8 @@ shootersRoom1 = do
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 putLamp
++ [sPS p (-pi/2) $ PutCrit autoCrit
,sPS (w/2,200) 0 putLamp
]
return $ set rmPS plmnts $ roomRectAutoLinks w 600
@@ -451,10 +451,10 @@ shootersRoom = do
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 putLamp
++ [sPS (x1,y1-10) (-pi/2) $ PutCrit autoCrit
,sPS (x2,y2-10) (-pi/2) $ PutCrit autoCrit
,sPS (x3,y3-10) (-pi/2) $ PutCrit autoCrit
,sPS (w/2,200) 0 putLamp
]
return $ set rmPS plmnts $ roomRectAutoLinks w 600
@@ -480,16 +480,16 @@ pistolerRoom = do
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/2,h-50) 0 putLamp
,PS (w/2,50) 0 putLamp
,PS (w-5,h-5) 0 putLamp
,PS (5,h-5) 0 putLamp
,PS (w-5,5) 0 putLamp
,PS (5,5) 0 putLamp
,PS (w/2,h/2) 0 putLamp
let plmnts = [sPS (ps !! 0) aa $ PutCrit pistolCrit
,sPS (ps !! 1) ab $ PutCrit pistolCrit
,sPS (ps !! 2) ac $ PutCrit pistolCrit
,sPS (w/2,h-50) 0 putLamp
,sPS (w/2,50) 0 putLamp
,sPS (w-5,h-5) 0 putLamp
,sPS (5,h-5) 0 putLamp
,sPS (w-5,5) 0 putLamp
,sPS (5,5) 0 putLamp
,sPS (w/2,h/2) 0 putLamp
]
++
concat [f x y | x<-xs,y<-ys]
@@ -515,13 +515,13 @@ 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 $ PutWall (rectNSWE (y-60) 0 (x/2-10) (x/2+10))
wl <- takeOne [sPS (0,0) 0 $ PutWall (rectNSWE (y-60) 0 (x/2-10) (x/2+10))
defaultCrystalWall
,windowLine (x/2,0) (x/2,y-60)
]
let plmnts = [PS (x/4, y/4) (pi/2) $ PutCrit spawnerCrit
let plmnts = [sPS (x/4, y/4) (pi/2) $ PutCrit spawnerCrit
,wl
,PS (x/2, y-10) 0 putLamp
,sPS (x/2, y-10) 0 putLamp
]
let f ((lx,_),_) = lx < x/2-5
roomWithSpawner <- (fmap connectRoom . randomiseOutLinks) =<< filterLinks f (set rmPS plmnts $ roomRect x y 2 2)
src/Dodge/Room/Airlock.hs
+14 -14
View File
@@ -22,9 +22,9 @@ airlockOneWay n = Room
{ _rmPolys = [rectNSWE 90 0 0 40]
, _rmLinks = lnks
, _rmPath = []
, _rmPS = [PS (0,15) 0 $ PutDoubleDoor col (not . cond) (0,0) (0,40)
,PS (0,75) 0 $ PutDoubleDoor col cond (0,0) (0,40)
,PS (35,45) (pi/2) $ PutButton $ makeButton col (over worldState
, _rmPS = [sPS (0,15) 0 $ PutDoubleDoor col (not . cond) (0,0) (0,40)
,sPS (0,75) 0 $ PutDoubleDoor col cond (0,0) (0,40)
,sPS (35,45) (pi/2) $ PutButton $ makeButton col (over worldState
(M.insert (DoorNumOpen n) True))
]
--, _rmBound = rectNSWE 90 30 (-30) 30
@@ -59,12 +59,12 @@ airlock0 n = Room
,((20,45),(20, 5))
]
, _rmPS =
[PS (0,20) 0 $ PutDoubleDoor col (not . cond) (1,0) (39,0)
,PS (0,80) 0 $ PutDoubleDoor col cond (1,0) (39,0)
,PS (35,50) (pi/2) $ PutButton $ makeSwitch col
[sPS (0,20) 0 $ PutDoubleDoor col (not . cond) (1,0) (39,0)
,sPS (0,80) 0 $ PutDoubleDoor col cond (1,0) (39,0)
,sPS (35,50) (pi/2) $ PutButton $ makeSwitch col
(over worldState (M.insert (DoorNumOpen n) True))
(over worldState (M.insert (DoorNumOpen n) False))
,PS (-25, 50) 0 putLamp
,sPS (-25, 50) 0 putLamp
]
, _rmBound = [rectNSWE 75 15 0 40]
}
@@ -98,11 +98,11 @@ airlock90 n = Room
,((40,0),(0,40))
]
, _rmPS =
[PS (5,5) 0 $ PutDoor col (not . cond) pss
,PS (120,120) (3* pi/4) $ PutButton $ makeSwitch col
[sPS (5,5) 0 $ PutDoor col (not . cond) pss
,sPS (120,120) (3* pi/4) $ PutButton $ makeSwitch col
(over worldState (M.insert (DoorNumOpen n) True))
(over worldState (M.insert (DoorNumOpen n) False))
,PS (60, 60) 0 putLamp
,sPS (60, 60) 0 putLamp
]
, _rmBound =
[[ (10,10)
@@ -138,13 +138,13 @@ airlockCrystal n = Room
[
]
, _rmPS =
[PS (0,0) 0 $ PutDoor col (not . cond) pss
,PS (145,70) (pi/2) $ PutButton $ makeSwitch col
[sPS (0,0) 0 $ PutDoor col (not . cond) pss
,sPS (145,70) (pi/2) $ PutButton $ makeSwitch col
(over worldState (M.insert (DoorNumOpen n) True))
(over worldState (M.insert (DoorNumOpen n) False))
,crystalLine (0,70) (40,70)
,PS (20, 40) 0 putLamp
,PS (20, 100) 0 putLamp
,sPS (20, 40) 0 putLamp
,sPS (20, 100) 0 putLamp
]
, _rmBound =
[ ]
src/Dodge/Room/Boss.hs
+12 -12
View File
@@ -34,10 +34,10 @@ roomGlassOctogon x = Room
, _rmPath = [((0,x),(0,-(x+40)))
,((0,-(x+40)),(0,x))]
, _rmPS =
[PS (fx,fx) 0 putLamp
,PS (-fx,fx) 0 putLamp
,PS (fx,-fx) 0 putLamp
,PS (-fx,-fx) 0 putLamp
[sPS (fx,fx) 0 putLamp
,sPS (-fx,fx) 0 putLamp
,sPS (fx,-fx) 0 putLamp
,sPS (-fx,-fx) 0 putLamp
,crystalLine (-x,x/2) (negate (x/2), x)
,crystalLine (x,x/2) (x/2, x)
,crystalLine (x/2,-x) (x,negate (x/2))
@@ -50,13 +50,13 @@ roomGlassOctogon x = Room
fx = 4 * x / 5
bossRoom :: RandomGen g => Creature -> State g Room
bossRoom cr = randomMediumRoom <&> rmPS %~ ( PS (0,100) (negate $ pi/2) (PutCrit cr) :)
bossRoom cr = randomMediumRoom <&> rmPS %~ ( sPS (0,100) (negate $ pi/2) (PutCrit cr) :)
armouredChasers :: RandomGen g => State g (Tree Room)
armouredChasers = do
ps <- takeN 5 [(x,y) | x <- [-100,-80 .. 100] ,y <- [-100,-80 .. 100] ]
as <- replicateM 5 . state $ randomR (0,2*pi)
let theCrits = zipWith3 (\p a c -> PS p a (PutCrit c)) ps as cs
let theCrits = zipWith3 (\p a c -> sPS p a (PutCrit c)) ps as cs
treeFromPost [corridor,corridor] <$> (randomMediumRoom <&> rmPS %~ (++ theCrits))
where
cs = (armourChaseCrit & crState . crDropsOnDeath .~ DropSpecific [0])
@@ -90,10 +90,10 @@ roomCross x y = Room
]
, _rmPath = []
, _rmPS =
[PS ( x, 0) 0 putLamp
,PS (-x, 0) 0 putLamp
,PS ( 0, x) 0 putLamp
,PS ( 0,-x) 0 putLamp
[sPS ( x, 0) 0 putLamp
,sPS (-x, 0) 0 putLamp
,sPS ( 0, x) 0 putLamp
,sPS ( 0,-x) 0 putLamp
]
, _rmBound =
[rectNSWE y (-y) (-x) x
@@ -116,7 +116,7 @@ roomShuriken x y =
{ _rmPolys = ps
, _rmLinks = [((x-1,y-20),negate $ pi/2)]
, _rmPath = []
, _rmPS = [PS (x/2,x/2) 0 putLamp]
, _rmPS = [sPS (x/2,x/2) 0 putLamp]
, _rmBound = ps
}
in foldr1 combineRooms $ map (\r -> shiftRoomBy ((0,0), r) corner) [0,pi/2,pi,3*pi/2]
@@ -140,7 +140,7 @@ roomTwistCross x y z =
{ _rmPolys = ps
, _rmLinks = [((z,y-20), pi/2)]
, _rmPath = []
, _rmPS = [PS (x/2,x/2) 0 putLamp]
, _rmPS = [sPS (x/2,x/2) 0 putLamp]
, _rmBound = ps
}
in foldr1 combineRooms $ map (\r -> shiftRoomBy ((0,0), r) corner) [0,pi/2,pi,3*pi/2]
src/Dodge/Room/Data.hs
+1 -1
View File
@@ -20,7 +20,7 @@ data Room = Room
{ _rmPolys :: [ [Point2] ]
, _rmLinks :: [(Point2,Float)]
, _rmPath :: [(Point2, Point2)]
, _rmPS :: [PlacementSpot]
, _rmPS :: [Placement]
, _rmBound :: [ [Point2] ]
}
makeLenses ''Room
src/Dodge/Room/Door.hs
+1 -1
View File
@@ -16,7 +16,7 @@ door = Room
, _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)]
, _rmPS = [sPS (0,20) 0 $ PutAutoDoor (0,0) (40,0)]
, _rmBound = []
}
where lnks = [((20,35),0)
src/Dodge/Room/Link.hs
+8 -4
View File
@@ -73,9 +73,13 @@ shiftRoomBy shift@(pos,rot) r =
r
shiftLinkBy (pos,rot) (p,r) = (shiftPointBy (pos,rot) p, r + rot)
shiftPSBy (pos,rot) ps = case ps of
PS {} -> over psPos (shiftPointBy (pos,rot))
$ over psRot (+rot)
ps
shiftPSBy (pos,rot) ps = ps
& placementSpot . psPos %~ shiftPointBy (pos,rot)
& placementSpot . psRot %~ (+ rot)
--shiftPSBy (pos,rot) ps = case ps of
-- PS {} -> over psPos (shiftPointBy (pos,rot))
-- $ over psRot (+rot)
-- ps
shiftPathPointBy s (p1,p2) = (shiftPointBy s p1, shiftPointBy s p2)
src/Dodge/Room/LongDoor.hs
+11 -11
View File
@@ -38,12 +38,12 @@ twinSlowDoorRoom drID w h x = Room
]
, _rmPath = []
, _rmPS =
[ PS (0,h/2) 0 putLamp
, PS (25,5) 0 putLamp
, PS (negate 25,5) 0 putLamp
, PS (0,0) 0 $ PutDoor col (not . cond) drL
, PS (0,0) 0 $ PutDoor col (not . cond) drR
, PS (0,h-5) pi $ PutButton $ makeButton col
[ sPS (0,h/2) 0 putLamp
, sPS (25,5) 0 putLamp
, sPS (negate 25,5) 0 putLamp
, sPS (0,0) 0 $ PutDoor col (not . cond) drL
, sPS (0,0) 0 $ PutDoor col (not . cond) drR
, sPS (0,h-5) pi $ PutButton $ makeButton col
(over worldState (M.insert (DoorNumOpen drID) True))
]
, _rmBound = ps
@@ -69,7 +69,7 @@ twinSlowDoorChasers drid = do
let lps = (-65 ,) <$> [20,40 .. 180]
rps = (65 ,) <$> [20,40 .. 180]
ps <- takeN 4 $ lps ++ rps
let plmnts = map (\p -> PS p 0 $ PutCrit chaseCrit) ps
let plmnts = map (\p -> sPS p 0 $ PutCrit chaseCrit) ps
return $ twinSlowDoorRoom drid 80 200 40 & rmPS %~ (plmnts ++)
slowDoorRoom :: RandomGen g => State g (Tree (Either Room Room))
@@ -88,9 +88,9 @@ slowDoorRoom = do
let ps = zip xs ys
xs' <- replicateM 5 $ state $ randomR (10,x-10)
ys' <- replicateM 5 $ state $ randomR (h+20,y)
let crits = zipWith (\p r -> PS p r randC1) ps rs
lsources = [PS (x/2,30) 0 putLamp, PS (x/2,y-30) 0 putLamp]
barrels = zipWith (\x y -> PS (x,y) 0 $ PutCrit explosiveBarrel) xs' ys'
let crits = zipWith (\p r -> sPS p r randC1) ps rs
lsources = [sPS (x/2,30) 0 putLamp, sPS (x/2,y-30) 0 putLamp]
barrels = zipWith (\x y -> sPS (x,y) 0 $ PutCrit explosiveBarrel) xs' ys'
pillarsa = []
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)
@@ -107,7 +107,7 @@ slowDoorRoom = do
fmap connectRoom
(filterLinks cond =<<
changeLinkTo cond2
(set rmPS ([PS (0,0) 0 but] ++ crits ++ pillars ++ barrels ++ lsources)
(set rmPS ([sPS (0,0) 0 but] ++ crits ++ pillars ++ barrels ++ lsources)
$ roomRectAutoLinks x y
)
)
src/Dodge/Room/NoNeedWeapon.hs
+5 -5
View File
@@ -29,11 +29,11 @@ centerVaultExplosiveExit
centerVaultExplosiveExit drID = do
cr <- takeOne [miniGunCrit, autoCrit]
let extraPS =
[PS (0,175) 0 $ PutCrit explosiveBarrel
,PS (5,195) 0 $ PutCrit explosiveBarrel
,PS (0,200) 0 $ PutCrit explosiveBarrel
,PS (-4,195) 0 $ PutCrit explosiveBarrel
,PS (0,0) 0 $ PutCrit (cr & crState . crDropsOnDeath .~ DropAll)
[sPS (0,175) 0 $ PutCrit explosiveBarrel
,sPS (5,195) 0 $ PutCrit explosiveBarrel
,sPS (0,200) 0 $ PutCrit explosiveBarrel
,sPS (-4,195) 0 $ PutCrit explosiveBarrel
,sPS (0,0) 0 $ PutCrit (cr & crState . crDropsOnDeath .~ DropAll)
]
r <- centerVaultRoom drID 200 200 50 <&> rmPS %~ (extraPS ++)
randomiseLinksBy shuffleTail r <&> rmLinks %~ take 2
src/Dodge/Room/Placement.hs
+12 -12
View File
@@ -15,15 +15,15 @@ import Control.Lens
putLamp = PutCrit lamp
singleBlock :: Point2 -> [PlacementSpot]
singleBlock a = [PS a 0 $ PutBlock [5,20,20] (greyN 0.5)
singleBlock :: Point2 -> [Placement]
singleBlock a = [sPS a 0 $ PutBlock [5,20,20] (greyN 0.5)
$ reverse $ rectNSWE 10 (-10) (-10) 10]
{-
Places a line of blocks between two points.
Width 9, also extends out from each point by 9.
-}
blockLine :: Point2 -> Point2 -> PlacementSpot
blockLine a b = PS
blockLine :: Point2 -> Point2 -> Placement
blockLine a b = SinglePlacement $ PS
{ _psPos = (0,0)
, _psRot = 0
, _psType = PutLineBlock baseBlockPane 9 9 a b
@@ -33,8 +33,8 @@ blockLine a b = PS
Places an breakable window between two points.
Width 8, also extends out from each point by 8.
-}
windowLine :: Point2 -> Point2 -> PlacementSpot
windowLine a b = PS
windowLine :: Point2 -> Point2 -> Placement
windowLine a b = SinglePlacement $ PS
{ _psPos = (0,0)
, _psRot = 0
, _psType = PutLineBlock baseWindowPane 8 8 a b
@@ -44,8 +44,8 @@ windowLine a b = PS
Places an unbreakable window between two points.
Width 7, also extends out from each point by 7.
-}
crystalLine :: Point2 -> Point2 -> PlacementSpot
crystalLine a b = PS
crystalLine :: Point2 -> Point2 -> Placement
crystalLine a b = SinglePlacement $ PS
{ _psPos = (0,0)
, _psRot = 0
, _psType = PutWall ps defaultCrystalWall
@@ -62,8 +62,8 @@ crystalLine a b = PS
{- Places an unbreakable wall between two points.
Depth 15, does not extend wider than points.
-}
wallLine :: Point2 -> Point2 -> PlacementSpot
wallLine a b = PS
wallLine :: Point2 -> Point2 -> Placement
wallLine a b = SinglePlacement $ PS
{ _psPos = (0,0)
, _psRot = 0
, _psType = PutWall ps defaultWall
@@ -114,7 +114,7 @@ replacePutID
-> Room
-> Room
replacePutID i psts r =
r & rmPS %~ flip (subZipWith (isPutID i) (\ps pt -> ps & psType .~ pt)) psts
r & rmPS %~ flip (subZipWith (isPutID i) (\ps pt -> ps & placementSpot . psType .~ pt)) psts
{- Partition a list by a predicate, apply a zip to those elements
that satisfy the predicate, concatenate
the new zipped list and the other (unchanged) half. -}
@@ -128,7 +128,7 @@ subZipWith f g xs ys =
let (zs,ws) = partition f xs
in zipWith g zs ys ++ ws
isPutID i ps = Just i == ps ^? psType . putID
isPutID i ps = Just i == ps ^? placementSpot . psType . putID
putBlockRect a x b y = [ blockLine (a,b) (a,y)
, blockLine (a,y) (x,y)
src/Dodge/Room/Procedural.hs
+33 -33
View File
@@ -43,7 +43,7 @@ roomRect x y xn yn = Room
{ _rmPolys = [rectNSWE y 0 0 x ]
, _rmLinks = lnks
, _rmPath = concatMap doublePair pth
, _rmPS = [PS (x/2,y/2) 0 putLamp]
, _rmPS = [sPS (x/2,y/2) 0 putLamp]
, _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)]
}
where
@@ -103,7 +103,7 @@ fourth w = Room
, _rmLinks = [((0,w), 0)]
, _rmPath = [((0,w),(0,0)),((0,0),(0,w))]
, _rmPS =
[PS (0,w/2) 0 putLamp
[sPS (0,w/2) 0 putLamp
]
, _rmBound = [[(0,0),(w,w),(-w,w)]]
}
@@ -112,19 +112,19 @@ 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 (0,40) 0 putLamp
, PS (w-20,w-20) pi PutNothing
[ [ sPS (20-w,w-40) 0 putLamp
, sPS (0,40) 0 putLamp
, sPS (w-20,w-20) pi PutNothing
, blockLine (w/2,w/2) (w/2,w)
]
, [ PS (20-w,w-40) 0 putLamp
, PS (0,40) 0 putLamp
, PS (w-20,w-20) pi PutNothing
, [ sPS (20-w,w-40) 0 putLamp
, sPS (0,40) 0 putLamp
, sPS (w-20,w-20) pi PutNothing
, blockLine (w/2,w/2) (negate $ w/2,w/2)
]
, [ PS (20-w,w-40) 0 putLamp
, PS (0,20) 0 putLamp
, PS (w-20,w-20) pi PutNothing
, [ sPS (20-w,w-40) 0 putLamp
, sPS (0,20) 0 putLamp
, sPS (w-20,w-20) pi PutNothing
, blockLine (w/2,w/2) (0,w/2)
, blockLine (-29,w) (0,w/2)
]
@@ -145,32 +145,32 @@ fourthCorner w = Room
,((negate $ w/2,3*w/2), pi/4)
]
, _rmPath = [((0,w),(0,0)),((0,0),(0,w))]
, _rmPS = [PS (0,w) 0 putLamp]
, _rmPS = [sPS (0,w) 0 putLamp]
, _rmBound = [[(w,w),(0,2*w),(-w,w)]]
}
fourthCornerWall :: RandomGen g => Float -> State g Room
fourthCornerWall w = do
b <- takeOne
[ [ PS (10-w,w) 0 putLamp
, PS (w-10,w) 0 putLamp
, PS (0,10) 0 putLamp
, PS (0,2*w-20) pi PutNothing
[ [ sPS (10-w,w) 0 putLamp
, sPS (w-10,w) 0 putLamp
, sPS (0,10) 0 putLamp
, sPS (0,2*w-20) pi PutNothing
, blockLine (w/2,w/2) (0,w)
, blockLine (negate $ w/2,w/2) (0,w)
]
, [ PS (0,3*w/2) 0 putLamp
, PS (w-10,w) 0 putLamp
, PS (10-w,w-20) 0 putLamp
, PS (0,10) 0 putLamp
, PS (0,2*w-20) pi PutNothing
, [ sPS (0,3*w/2) 0 putLamp
, sPS (w-10,w) 0 putLamp
, sPS (10-w,w-20) 0 putLamp
, sPS (0,10) 0 putLamp
, sPS (0,2*w-20) pi PutNothing
, blockLine (w/2,w/2) (0,w)
, blockLine (negate w,w) (0,w)
]
, [ PS (10-w,w) 0 putLamp
, PS (w-10,w) 0 putLamp
, PS (0,10) 0 putLamp
, PS (20,2*w-40) pi PutNothing
, [ sPS (10-w,w) 0 putLamp
, sPS (w-10,w) 0 putLamp
, sPS (0,10) 0 putLamp
, sPS (20,2*w-40) pi PutNothing
, blockLine (w/2,w/2) (0,w)
, blockLine (0,w) (0,w*2)
]
@@ -190,7 +190,7 @@ fillNothingPlacement :: PSType -> Room -> Room
fillNothingPlacement pst r =
r & rmPS %~ replaceNothingWith pst
where
replaceNothingWith x (PS p rot PutNothing: pss) = PS p rot x : pss
replaceNothingWith x (SinglePlacement (PS p rot PutNothing): pss) = sPS p rot x : pss
replaceNothingWith x (ps:pss) = ps : replaceNothingWith x pss
replaceNothingWith _ [] = []
{- | Successively fill 'PutNothing' placements with a list of given 'PSType's.
@@ -243,11 +243,11 @@ centerVaultRoom n w h d = do
]
, _rmPath = []
, _rmPS =
[PS (d-25,d-25) 0 putLamp
,PS (w-5,h-5) 0 putLamp
,PS (w-5,5-h) 0 putLamp
,PS (5-w,h-5) 0 putLamp
,PS (5-w,5-h) 0 putLamp
[sPS (d-25,d-25) 0 putLamp
,sPS (w-5,h-5) 0 putLamp
,sPS (w-5,5-h) 0 putLamp
,sPS (5-w,h-5) 0 putLamp
,sPS (5-w,5-h) 0 putLamp
]
++ 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])
@@ -256,8 +256,8 @@ centerVaultRoom n w h d = do
where
col = dim $ dim $ bright red
theDoor i =
[ PS (0,d-10) 0 $ PutDoubleDoor col (cond i) (-19,0) (19,0)
, PS (35,d+4) 0 $ PutButton $ makeSwitch col
[ sPS (0,d-10) 0 $ PutDoubleDoor col (cond i) (-19,0) (19,0)
, sPS (35,d+4) 0 $ PutButton $ makeSwitch col
(over worldState (M.insert (DoorNumOpen i) True))
(over worldState (M.insert (DoorNumOpen i) False))
]
src/Dodge/Room/RoadBlock.hs
+8 -8
View File
@@ -40,12 +40,12 @@ litCorridor90 = do
,((40,h-40),(20,h-40))
]
, _rmPS =
[ PS (20,h-5) 0 putLamp
[ sPS (20,h-5) 0 putLamp
, windowLine (0,h-20) (40,h-20)
, PS (-50,h-85) 0 putLamp
, sPS (-50,h-85) 0 putLamp
, windowLine (-40,h-60) (-40,h-100)
, PS ( 20,h-40) 0 $ PutID 0
, PS (-20,h-80) 0 $ PutID 2
, sPS ( 20,h-40) 0 $ PutID 0
, sPS (-20,h-80) 0 $ PutID 2
]
, _rmBound = [poly]
}
@@ -59,9 +59,9 @@ longBlockedCorridor :: RandomGen g => State g (Tree (Either Room Room))
longBlockedCorridor = 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)
let plmnts = [sPS (20,40) r $ PutBlock [5,5,5] (150/256, 75/256, 0, 250/256)
$ reverse $ rectNSWE 10 (-10) (-10) 10
,PS (20,15) 0 putLamp
,sPS (20,15) 0 putLamp
]
sequence $ treeFromPost (replicate n $ Left <$> randomiseOutLinks corridor)
$ return $ Right $ set rmPS plmnts corridor
@@ -70,8 +70,8 @@ longBlockedCorridor = do
blockedCorridor :: RandomGen g => State g (Tree (Either Room Room))
blockedCorridor = do
r <- state $ randomR (0,pi)
let plmnts = [PS (20,40) r $ PutBlock [5,5,5] (150/256, 75/256, 0, 250/256)
let plmnts = [sPS (20,40) r $ PutBlock [5,5,5] (150/256, 75/256, 0, 250/256)
$ reverse $ rectNSWE 10 (-10) (-10) 10
,PS (20,15) 0 putLamp
,sPS (20,15) 0 putLamp
]
sequence $ treeFromPost [] $ return $ Right $ set rmPS plmnts corridor
src/Dodge/Room/Teleport.hs
+2 -2
View File
@@ -28,8 +28,8 @@ telRoomLev i = do
w <- state $ randomR (200,300)
h <- state $ randomR (200,300)
return $ roomRectAutoLinks w h & rmPS .~
[ PS (w/2,h/2) 0 $ PutPressPlate telPP
, PS (w/2,h/2+ 30) 0 putLamp
[ sPS (w/2,h/2) 0 $ PutPressPlate telPP
, sPS (w/2,h/2+ 30) 0 putLamp
]
where
telPP = PressPlate
src/Dodge/Room/Treasure.hs
+13 -18
View File
@@ -1,4 +1,4 @@
{-
{- |
Rooms that contain valuable items, typically protected in some manner.
Typically dead ends.
-}
@@ -13,13 +13,10 @@ import Dodge.LevelGen.Data
import Data.List
import Control.Monad.State
import Control.Lens
import System.Random
{-
A triangular room with loot at the top (with 'PutID' 2),
import System.Random
{- | A triangular room with loot at the top (with 'PutID' 2),
creatures in the bottom two corners (with 'PutID' 0),
and (single) entrance bottom middle.
-}
and (single) entrance bottom middle. -}
triLootRoom
:: Float -- Width
-> Float -- Height
@@ -31,13 +28,13 @@ triLootRoom w h = pure $ Room
, _rmLinks = [((0,-80),pi)]
, _rmPath = doublePair ((0,-80),(0,h/2))
, _rmPS =
[PS (15-w,15) 0 $ PutID 0
,PS (w-15,15) pi $ PutID 0
,PS (0,h-35) 0 $ PutID 2
,PS (-5,h-10) 0 putLamp
,PS (5,h-10) 0 putLamp
,PS (0,h-15) 0 putLamp
,PS (0,-60) 0 putLamp
[sPS (15-w, 15) 0 $ PutID 0
,sPS (w-15, 15) pi $ PutID 0
,sPS ( 0,h-35) 0 $ PutID 2
,sPS ( -5,h-10) 0 putLamp
,sPS ( 5,h-10) 0 putLamp
,sPS ( 0,h-15) 0 putLamp
,sPS ( 0, -60) 0 putLamp
]
, _rmBound = [tri , base]
}
@@ -50,10 +47,8 @@ triLootRoom w h = pure $ Room
, ( 20, h)
, (-20, h)
]
base = rectNSWE 20 (-80) (-20) 20
{- Create a random room with one entrance containing given creatures and items.
-}
base = rectNSWE 20 (-80) (-20) 20
{- | Create a random room with one entrance containing given creatures and items. -}
lootRoom :: RandomGen g => [Creature] -> [Item] -> State g Room
lootRoom crs itms = do
let w = 300