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

Refactor, try to limit dependencies

Browse Source
This commit is contained in:
justin
2022-07-28 00:59:56 +01:00
parent 8aa5c17ab9
commit 160560af5f
418 changed files with 15104 additions and 13342 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Room/Airlock.hs
+152 -126
View File
@@ -1,157 +1,183 @@
{-# LANGUAGE TupleSections #-}
{- Rooms that contain two doors and a switch alternating both. -}
module Dodge.Room.Airlock where
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.Room.Foreground
import Dodge.RoomLink
import Dodge.Default.Room
import Dodge.Default.Door
import Dodge.Data
import Dodge.LevelGen.Data
import Dodge.LevelGen.Switch
import RandomHelp
import Geometry
import Picture
import RandomHelp
--import Control.Lens
{- | A passage with a switch that opens forward access while closing backwards access. -}
-- | A passage with a switch that opens forward access while closing backwards access.
airlock :: RandomGen g => State g Room
airlock = takeOne [airlock0,airlock90,airlockCrystal,airlockZ]
airlock = takeOne [airlock0, airlock90, airlockCrystal, airlockZ]
--airlock = takeOne [airlockCrystal]
{- | Straight airlock -}
-- | Straight airlock
airlock0 :: Room
airlock0 = defaultRoom
{ _rmPolys = [ rectNSWE 100 0 0 40 , switchcut]
, _rmLinks = muout lnks ++ muin [last lnks]
, _rmPath = foldMap doublePairSet [(V2 20 95,V2 20 45) ,(V2 20 45,V2 20 5) ]
, _rmPmnts =
[pContID (PS (V2 (-35) 50) (negate $ pi/2)) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect)
$ \btid -> Just $ putDoubleDoorThen DoorObstacle thewall (WdBlNegate $ WdBlBtOn btid) 1 (V2 0 20) (V2 40 20) 2
$ \_ _ -> Just $ putDoubleDoor DoorObstacle thewall (WdBlBtOn btid) (V2 0 80) (V2 40 80) 2
, invisibleWall $ rectNSWE 60 40 (-40) (-30)
,spanLightI (V2 (-2) 30) (V2 (-2) 70)
,sps0 $ putShape $ thinHighBar 75 (V2 40 50) (V2 (-1) 50)
]
, _rmBound = [rectNSWE 75 15 0 40,switchcut]
}
where
airlock0 =
defaultRoom
{ _rmPolys = [rectNSWE 100 0 0 40, switchcut]
, _rmLinks = muout lnks ++ muin [last lnks]
, _rmPath = foldMap doublePairSet [(V2 20 95, V2 20 45), (V2 20 45, V2 20 5)]
, _rmPmnts =
[ pContID (PS (V2 (-35) 50) (negate $ pi / 2)) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect) $
\btid -> Just $
putDoubleDoorThen DoorObstacle thewall (WdBlNegate $ WdBlBtOn btid) 1 (V2 0 20) (V2 40 20) 2 $
\_ _ -> Just $ putDoubleDoor DoorObstacle thewall (WdBlBtOn btid) (V2 0 80) (V2 40 80) 2
, invisibleWall $ rectNSWE 60 40 (-40) (-30)
, spanLightI (V2 (-2) 30) (V2 (-2) 70)
, sps0 $ putShape $ thinHighBar 75 (V2 40 50) (V2 (-1) 50)
]
, _rmBound = [rectNSWE 75 15 0 40, switchcut]
}
where
thewall = switchWallCol col
switchcut = rectNSWE 65 35 (-40) 20
lnks = [(V2 20 95,0)
,(V2 20 5,pi)
]
switchcut = rectNSWE 65 35 (-40) 20
lnks =
[ (V2 20 95, 0)
, (V2 20 5, pi)
]
col = dim $ dim $ bright red
airlockDoor :: Color -> WdBl -> [(Point2,Point2)] -> PSType
airlockDoor :: Color -> WdBl -> [(Point2, Point2)] -> PSType
airlockDoor col = PutDoor col DoorObstacle
airlockDoubleDoor :: Point2 -> Point2 -> Color -> WdBl -> [(Point2,Point2)]
-> [(Point2,Point2)] -> Maybe Placement
airlockDoubleDoor p1 p2 col cond outDoorps inDoorps = jspsJ p1 0 (airlockDoor col cond outDoorps)
$ sPS p2 0 (airlockDoor col cond inDoorps)
airlockDoubleDoor ::
Point2 ->
Point2 ->
Color ->
WdBl ->
[(Point2, Point2)] ->
[(Point2, Point2)] ->
Maybe Placement
airlockDoubleDoor p1 p2 col cond outDoorps inDoorps =
jspsJ p1 0 (airlockDoor col cond outDoorps) $
sPS p2 0 (airlockDoor col cond inDoorps)
airlockSimple :: Room
airlockSimple = defaultRoom
{ _rmPolys =
[ rectNSWE 120 0 0 180 ]
, _rmLinks = map (uncurry outLink) (init lnks) ++ [uncurry inLink $ last lnks]
, _rmPath = foldMap (doublePairSet . (V2 90 30,) . fst) lnks
, _rmPmnts =
[pContID (PS (V2 90 115) pi) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect)
$ \btid -> airlockDoubleDoor 0 (V2 180 0) col (WdBlBtOn btid) outDoorps inDoorps
-- jspsJ (V2 0 0) 0 (airlockDoor col (cond btid) outDoorps)
-- $ sPS (V2 180 0) 0 (airlockDoor col (cond btid) inDoorps)
airlockSimple =
defaultRoom
{ _rmPolys =
[rectNSWE 120 0 0 180]
, _rmLinks = map (uncurry outLink) (init lnks) ++ [uncurry inLink $ last lnks]
, _rmPath = foldMap (doublePairSet . (V2 90 30,) . fst) lnks
, _rmPmnts =
[ pContID (PS (V2 90 115) pi) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect) $
\btid -> airlockDoubleDoor 0 (V2 180 0) col (WdBlBtOn btid) outDoorps inDoorps
-- jspsJ (V2 0 0) 0 (airlockDoor col (cond btid) outDoorps)
-- $ sPS (V2 180 0) 0 (airlockDoor col (cond btid) inDoorps)
]
, _rmBound =
[rectNSWE 120 0 0 180]
}
where
lnks =
[ (V2 0 30, pi / 2)
, (V2 180 30, 1.5 * pi)
]
, _rmBound =
[ rectNSWE 120 0 0 180 ]
}
where
lnks =
[(V2 0 30,pi/2)
,(V2 180 30,1.5*pi)
]
col = dim $ dim $ bright red
outDoorps = (V2 0 0 ,) <$> arcStepwise 3 (negate $ pi/2) (V2 0 0) (V2 0 55)
inDoorps = (V2 0 0 ,) <$> arcStepwise 3 (negate $ pi/2) (V2 0 0) (V2 (-55) 0)
outDoorps = (V2 0 0,) <$> arcStepwise 3 (negate $ pi / 2) (V2 0 0) (V2 0 55)
inDoorps = (V2 0 0,) <$> arcStepwise 3 (negate $ pi / 2) (V2 0 0) (V2 (-55) 0)
airlockZ :: Room
airlockZ = defaultRoom
{ _rmPolys =
[ rectNSWE 120 0 0 180 ]
, _rmLinks = muout[(V2 0 30,pi/2)] ++ muin[(V2 180 30,1.5*pi) ]
, _rmPath = mempty
-- [(V2 0 40,V2 40 0)
-- ,(V2 40 0,V2 0 40)
-- ]
, _rmPmnts =
[pContID (PS (V2 90 115) pi) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect)
$ \btid -> airlockDoubleDoor (V2 0 60) (V2 180 60) col (WdBlBtOn btid) outDoorps inDoorps
-- jspsJ (V2 0 60) 0 (airlockDoor col (cond btid) outDoorps)
-- $ sPS (V2 180 60) 0 (airlockDoor col (cond btid) inDoorps)
, sps0 $ PutWall (reverse $ rectNSWE 70 50 60 120) defaultWall
, lighting
]
, _rmBound =
[ rectNSWE 120 0 0 180 ]
}
where
airlockZ =
defaultRoom
{ _rmPolys =
[rectNSWE 120 0 0 180]
, _rmLinks = muout [(V2 0 30, pi / 2)] ++ muin [(V2 180 30, 1.5 * pi)]
, _rmPath = mempty
, -- [(V2 0 40,V2 40 0)
-- ,(V2 40 0,V2 0 40)
-- ]
_rmPmnts =
[ pContID (PS (V2 90 115) pi) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect) $
\btid -> airlockDoubleDoor (V2 0 60) (V2 180 60) col (WdBlBtOn btid) outDoorps inDoorps
, -- jspsJ (V2 0 60) 0 (airlockDoor col (cond btid) outDoorps)
-- $ sPS (V2 180 60) 0 (airlockDoor col (cond btid) inDoorps)
sps0 $ PutWall (reverse $ rectNSWE 70 50 60 120) defaultWall
, lighting
]
, _rmBound =
[rectNSWE 120 0 0 180]
}
where
col = dim $ dim $ bright red
outDoorps = (V2 0 0 ,) <$> arcStepwise 3 (pi/2) (V2 0 0) (V2 0 (-61))
inDoorps = (V2 0 0 ,) <$> arcStepwise 3 (pi/2) (V2 0 0) (V2 (-61) 0)
cenlight = mntLS vShape (V2 90 60) (V3 90 40 50) `addPlmnt` mntLS vShape (V2 90 60) (V3 90 80 50)
cornlight = mntLS vShape (V2 0 120) (V3 30 90 50) `addPlmnt` mntLS vShape (V2 180 120) (V3 150 90 50)
`addPlmnt` sps0 (putShape (thinHighBar 50 (V2 30 90) (V2 150 90)))
lighting = RandomPlacement $ takeOne [cenlight,cornlight]
outDoorps = (V2 0 0,) <$> arcStepwise 3 (pi / 2) (V2 0 0) (V2 0 (-61))
inDoorps = (V2 0 0,) <$> arcStepwise 3 (pi / 2) (V2 0 0) (V2 (-61) 0)
cenlight = mntLS vShape (V2 90 60) (V3 90 40 50) `addPlmnt` mntLS vShape (V2 90 60) (V3 90 80 50)
cornlight =
mntLS vShape (V2 0 120) (V3 30 90 50) `addPlmnt` mntLS vShape (V2 180 120) (V3 150 90 50)
`addPlmnt` sps0 (putShape (thinHighBar 50 (V2 30 90) (V2 150 90)))
lighting = RandomPlacement $ takeOne [cenlight, cornlight]
airlock90 :: Room
airlock90 = defaultRoom
{ _rmPolys =
[ rectNSWE 100 10 10 100
, rectNSWE 20 0 20 60
, rectNSWE 20 60 20 0
, map toV2 [ (10,100)
, (100,150)
, (150,100)
, (100,10)
airlock90 =
defaultRoom
{ _rmPolys =
[ rectNSWE 100 10 10 100
, rectNSWE 20 0 20 60
, rectNSWE 20 60 20 0
, map
toV2
[ (10, 100)
, (100, 150)
, (150, 100)
, (100, 10)
]
]
]
, _rmLinks = muout[(V2 0 40,pi/2)] ++ muin[(V2 40 0,pi) ]
, _rmPath = doublePairSet (V2 0 40,V2 40 0)
, _rmPmnts =
[ pContID (PS (V2 120 120) (3 * pi/4)) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect)
$ \btid -> jsps (V2 5 5) 0 $ airlockDoor col (WdBlBtOn btid) pss
, mntLS vShape (V2 35 35) (V3 70 70 50)
]
, _rmBound =
[map toV2 [ (10,10)
, (10,100)
, (100,150)
, (150,100)
, (100,10)
]]
, _rmName = "airlock90"
}
where
, _rmLinks = muout [(V2 0 40, pi / 2)] ++ muin [(V2 40 0, pi)]
, _rmPath = doublePairSet (V2 0 40, V2 40 0)
, _rmPmnts =
[ pContID (PS (V2 120 120) (3 * pi / 4)) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect) $
\btid -> jsps (V2 5 5) 0 $ airlockDoor col (WdBlBtOn btid) pss
, mntLS vShape (V2 35 35) (V3 70 70 50)
]
, _rmBound =
[ map
toV2
[ (10, 10)
, (10, 100)
, (100, 150)
, (150, 100)
, (100, 10)
]
]
, _rmName = "airlock90"
}
where
--cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
col = dim $ dim $ bright red
pss = (V2 0 0 ,) <$> arcStepwise 3 (negate $ pi/2) (V2 0 0) (V2 0 55)
pss = (V2 0 0,) <$> arcStepwise 3 (negate $ pi / 2) (V2 0 0) (V2 0 55)
airlockCrystal :: Room
airlockCrystal = defaultRoom
{ _rmPolys = [ rectNSWE 140 0 0 40 , switchcutout ]
, _rmLinks = muout[(V2 20 130,0) ] ++ muin[(V2 20 0 ,pi) ]
, _rmPath = mempty
, _rmPmnts =
[pContID (PS (V2 145 70) (pi/2)) ( PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect)
$ \btid -> jsps0 $ airlockDoor col (WdBlBtOn btid) pss
, crystalLine (V2 0 70) (V2 40 70)
, mntLS vShape (V2 150 70) (V3 110 70 70)
]
, _rmBound = [ rectNSWE 120 20 0 40 , switchcutout ]
}
where
switchcutout = orderPolygon $ map toV2 [ (39,20) , (150,60) , (150,80) , (39,120) ]
airlockCrystal =
defaultRoom
{ _rmPolys = [rectNSWE 140 0 0 40, switchcutout]
, _rmLinks = muout [(V2 20 130, 0)] ++ muin [(V2 20 0, pi)]
, _rmPath = mempty
, _rmPmnts =
[ pContID (PS (V2 145 70) (pi / 2)) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect) $
\btid -> jsps0 $ airlockDoor col (WdBlBtOn btid) pss
, crystalLine (V2 0 70) (V2 40 70)
, mntLS vShape (V2 150 70) (V3 110 70 70)
]
, _rmBound = [rectNSWE 120 20 0 40, switchcutout]
}
where
switchcutout = orderPolygon $ map toV2 [(39, 20), (150, 60), (150, 80), (39, 120)]
col = dim $ dim $ bright red
pss :: [(Point2,Point2)]
pss = reverse $ fmap ( (\x -> (V2 50 (x - 10),V2 50 (x+60)) ) . fromIntegral)
[20::Int,22..70]
pss :: [(Point2, Point2)]
pss =
reverse $
fmap
((\x -> (V2 50 (x - 10), V2 50 (x + 60))) . fromIntegral)
[20 :: Int, 22 .. 70]
src/Dodge/Room/BlinkAcross.hs
+15 -37
View File
@@ -1,50 +1,28 @@
module Dodge.Room.BlinkAcross where
--import Dodge.LevelGen.Data
import Dodge.PlacementSpot
import Control.Monad.State
import Dodge.Cleat
import Dodge.Data
import Dodge.Tree
--import Dodge.RoomLink
--import Dodge.Room.Door
import Dodge.Data.GenWorld
import Dodge.PlacementSpot
import Dodge.Room.Corridor
import Dodge.Room.Link
--import Dodge.Room.Ngon
import Dodge.Room.Procedural
--import Dodge.Room.Foreground
--import Dodge.Room.RoadBlock
--import Dodge.Placement.Instance
--import Dodge.Placement.Instance.Analyser
--import Dodge.Default.Room
--import Dodge.Item.Consumable
--import Dodge.Machine
--import Dodge.Item.Weapon.Utility
--import Dodge.LevelGen.Data
--import Geometry.Data
--import Geometry
--import Padding
--import Color
--import Shape
import Dodge.Tree
import LensHelp
--import Dodge.RandomHelp
--import Dodge.SoundLogic
--import qualified Data.Set as S
--import Data.Maybe
--import Data.Tree
import Control.Monad.State
import System.Random
blinkAcrossChallenge :: RandomGen g => State g (MetaTree Room String)
blinkAcrossChallenge = do
teleFromRoom <- shuffleLinks $ roomRectAutoLinks 200 200
teleToRoom <- shuffleLinks $ roomRectAutoLinks 200 200
emptylink <- shuffleLinks emptyCorridor
rToOnward "blinkAcrossChallenge"
$ treePost [ teleFromRoom, emptylink, cleatOnward teleToRoom]
teleToRoom <- shuffleLinks $ roomRectAutoLinks 200 200
emptylink <- shuffleLinks emptyCorridor
rToOnward "blinkAcrossChallenge" $
treePost [teleFromRoom, emptylink, cleatOnward teleToRoom]
emptyCorridor :: Room
emptyCorridor = corridor & rmPolys .~ []
& rmPath .~ mempty
& rmPmnts .~ []
& rmRandPSs .~ [psRandRanges (10,30) (30,60) (0,2*pi)]
& rmName .~ "WalledCorridor"
emptyCorridor =
corridor & rmPolys .~ []
& rmPath .~ mempty
& rmPmnts .~ []
& rmRandPSs .~ [psRandRanges (10, 30) (30, 60) (0, 2 * pi)]
& rmName .~ "WalledCorridor"
src/Dodge/Room/Boss.hs
+160 -130
View File
@@ -1,151 +1,181 @@
{- Rooms containing particularly challenging creatures, that may drop useful loot. -}
module Dodge.Room.Boss
where
import Dodge.Data
import Dodge.RoomLink
import Dodge.Default.Room
import Dodge.Placement.Instance
import Dodge.LevelGen.Data
import Dodge.Room.Procedural
import Dodge.Room.Link
import Dodge.Room.Corridor
import Dodge.Room.Path
--import Dodge.LevelGen.Data
module Dodge.Room.Boss where
import Dodge.Creature
import RandomHelp
import Dodge.Tree
import Dodge.Data.GenWorld
import Dodge.Default.Room
import Dodge.LevelGen.Data
import Dodge.LevelGen.StaticWalls
import Dodge.Placement.Instance
import Dodge.Room.Corridor
import Dodge.Room.Link
import Dodge.Room.Path
import Dodge.Room.Procedural
import Dodge.RoomLink
import Dodge.Tree
import Geometry
import LensHelp
import RandomHelp
roomGlassOctogon
:: Float -- ^ Size
-> Room
roomGlassOctogon x = createPathGrid $ defaultRoom
{ _rmPolys =
[rectNSWE x (-x) (-x) x
,rectNSWE 0 (-(x + 40)) (-20) 20
]
, _rmLinks = map (uncurry outLink) (init lnks) ++ [uncurry inLink $ last lnks]
, _rmPath = linksAndPath lnks
[ ( V2 0 x , V2 0 (-(x+40)))
, ( V2 0 (-(x+40)), V2 0 x)
]
, _rmPmnts =
[sPS (V2 fx fx) 0 putLamp
,sPS (V2 (-fx) fx) 0 putLamp
,sPS (V2 fx (-fx)) 0 putLamp
,sPS (V2 (-fx) (-fx)) 0 putLamp
,crystalLine (V2 (-x) (x/2)) (V2 (negate (x/2)) x)
,crystalLine (V2 x (x/2)) (V2 (x/2) x)
,crystalLine (V2 (x/2) (-x)) (V2 x (negate (x/2)))
,crystalLine (V2 (negate $ x/2) (-x)) (V2 (-x) (negate (x/2)))
,blockLine (V2 (-40) (50-x)) (V2 40 (50-x))
]
, _rmBound = [rectNSWE x (-x) (-x) x]
, _rmName = "glass8gon"
}
roomGlassOctogon ::
-- | Size
Float ->
Room
roomGlassOctogon x =
createPathGrid $
defaultRoom
{ _rmPolys =
[ rectNSWE x (- x) (- x) x
, rectNSWE 0 (- (x + 40)) (-20) 20
]
, _rmLinks = map (uncurry outLink) (init lnks) ++ [uncurry inLink $ last lnks]
, _rmPath =
linksAndPath
lnks
[ (V2 0 x, V2 0 (- (x + 40)))
, (V2 0 (- (x + 40)), V2 0 x)
]
, _rmPmnts =
[ sPS (V2 fx fx) 0 putLamp
, sPS (V2 (- fx) fx) 0 putLamp
, sPS (V2 fx (- fx)) 0 putLamp
, sPS (V2 (- fx) (- fx)) 0 putLamp
, crystalLine (V2 (- x) (x / 2)) (V2 (negate (x / 2)) x)
, crystalLine (V2 x (x / 2)) (V2 (x / 2) x)
, crystalLine (V2 (x / 2) (- x)) (V2 x (negate (x / 2)))
, crystalLine (V2 (negate $ x / 2) (- x)) (V2 (- x) (negate (x / 2)))
, blockLine (V2 (-40) (50 - x)) (V2 40 (50 - x))
]
, _rmBound = [rectNSWE x (- x) (- x) x]
, _rmName = "glass8gon"
}
where
fx = 4 * x / 5
lnks =
[ (V2 0 x,0)
, (V2 0 (-(x+40)),pi)
lnks =
[ (V2 0 x, 0)
, (V2 0 (- (x + 40)), pi)
]
bossRoom :: RandomGen g => Creature -> State g Room
bossRoom cr = randomMediumRoom <&> rmPmnts .:~ sPS (V2 0 100) (negate $ pi/2) (PutCrit cr)
bossRoom cr = randomMediumRoom <&> rmPmnts .:~ sPS (V2 0 100) (negate $ pi / 2) (PutCrit cr)
armouredChasers :: RandomGen g => State g (Tree Room)
armouredChasers = do
ps <- takeN 5 [V2 x y | x <- [-100,-80 .. 100] ,y <- [-100,-80 .. 100] ]
as <- replicateM 5 . state $ randomR (0,2*pi)
ps <- takeN 5 [V2 x y | x <- [-100, -80 .. 100], y <- [-100, -80 .. 100]]
as <- replicateM 5 . state $ randomR (0, 2 * pi)
let theCrits = zipWith3 (\p a c -> sPS p a (PutCrit c)) ps as cs
treeFromPost [corridor,corridor] <$> (randomMediumRoom <&> rmPmnts %~ (++ theCrits))
treeFromPost [corridor, corridor] <$> (randomMediumRoom <&> rmPmnts %~ (++ theCrits))
where
cs = (armourChaseCrit & crState . csDropsOnDeath .~ DropSpecific [0])
: replicate 4 chaseCrit
cs =
(armourChaseCrit & crState . csDropsOnDeath .~ DropSpecific [0]) :
replicate 4 chaseCrit
randomMediumRoom :: RandomGen g => State g Room
randomMediumRoom = takeOne
[ roomGlassOctogon 300
, roomCross 180 300
, roomShuriken 200 300
, roomTwistCross 230 300 0
]
randomMediumRoom =
takeOne
[ roomGlassOctogon 300
, roomCross 180 300
, roomShuriken 200 300
, roomTwistCross 230 300 0
]
roomCross
:: Float -- ^ First width/2
-> Float -- ^ Second width/2
-> Room
roomCross x y = defaultRoom
{ _rmPolys = [rectNSWE y (-y) (-x) x
,rectNSWE (-x) x y (-y)
]
, _rmLinks = map (uncurry outLink)
[(V2 x (y-20),negate $ pi/2)
,(V2 x (20-y),negate $ pi/2)
,(V2 (20-y) x ,0)
,(V2 (y-20) x ,0)
,(V2 (-x) (y-20),pi/2)
,(V2 (-x) (20-y),pi/2)
,(V2 (20-y) (-x),pi)
] ++
[uncurry inLink (V2 (y-20) (-x),pi)
]
, _rmPath = mempty
, _rmPmnts =
[ spanLightI (V2 (x+5) x) (V2 (x+5) (-x))
, spanLightI (V2 (-x-5) x) (V2 (-x-5) (-x))
]
, _rmBound =
[rectNSWE y (-y) (-x) x
,rectNSWE x (-x) (-y) y
]
, _rmName = "cross"
}
{- | TODO: pathing -}
roomShuriken
:: Float -- ^ First width/2
-> Float -- ^ Second width/2
-> Room
roomShuriken x y =
let ps = [ map toV2
[ (0,-20)
, (x,-20)
, (x,y)
, (0,x)
] ]
corner = defaultRoom
{ _rmPolys = ps
, _rmLinks = [toBothLnk (V2 (x-1) (y-20),negate $ pi/2)]
, _rmPath = mempty
, _rmPmnts = [mntLS iShape (V2 x x) (V3 (x-20) x 70)]
, _rmBound = ps
}
in (foldr1 combineRooms $ map (\r -> moveRoomBy (V2 0 0, r) corner) [0,pi/2,pi,3*pi/2])
{_rmName = "shuriken"}
{- | TODO: pathing
Precondition: first float is less than the second by at least 40. -}
roomTwistCross
:: Float -- ^ First width/2,
-> Float -- ^ Second width/2, should be biggest
-> Float -- ^ Third width, should be smallest, possibly negative
-> Room
roomTwistCross x y z =
let ps = [ map toV2 [ (x,negate $ z+20)
, (x,x)
, (z,y)
, (z-20,x)
, (z,negate $ z+20)
]
, rectNSWE (x-5) 0 0 (x-5)
roomCross ::
-- | First width/2
Float ->
-- | Second width/2
Float ->
Room
roomCross x y =
defaultRoom
{ _rmPolys =
[ rectNSWE y (- y) (- x) x
, rectNSWE (- x) x y (- y)
]
corner = defaultRoom
{ _rmPolys = ps
, _rmLinks = [toBothLnk (V2 z (y-20), pi/2)]
, _rmPath = mempty
, _rmPmnts = [mntLS iShape (V2 x x) (V3 (x-20) (x-20) 70)]
, _rmBound = map (expandPolyCorners 10) ps
, _rmLinks =
map
(uncurry outLink)
[ (V2 x (y -20), negate $ pi / 2)
, (V2 x (20 - y), negate $ pi / 2)
, (V2 (20 - y) x, 0)
, (V2 (y -20) x, 0)
, (V2 (- x) (y -20), pi / 2)
, (V2 (- x) (20 - y), pi / 2)
, (V2 (20 - y) (- x), pi)
]
++ [ uncurry inLink (V2 (y -20) (- x), pi)
]
, _rmPath = mempty
, _rmPmnts =
[ spanLightI (V2 (x + 5) x) (V2 (x + 5) (- x))
, spanLightI (V2 (- x -5) x) (V2 (- x -5) (- x))
]
, _rmBound =
[ rectNSWE y (- y) (- x) x
, rectNSWE x (- x) (- y) y
]
, _rmName = "cross"
}
-- | TODO: pathing
roomShuriken ::
-- | First width/2
Float ->
-- | Second width/2
Float ->
Room
roomShuriken x y =
let ps =
[ map
toV2
[ (0, -20)
, (x, -20)
, (x, y)
, (0, x)
]
]
corner =
defaultRoom
{ _rmPolys = ps
, _rmLinks = [toBothLnk (V2 (x -1) (y -20), negate $ pi / 2)]
, _rmPath = mempty
, _rmPmnts = [mntLS iShape (V2 x x) (V3 (x -20) x 70)]
, _rmBound = ps
}
in (foldr1 combineRooms $ map (\r -> moveRoomBy (V2 0 0, r) corner) [0, pi / 2, pi, 3 * pi / 2])
{ _rmName = "shuriken"
}
{- | TODO: pathing
Precondition: first float is less than the second by at least 40.
-}
roomTwistCross ::
-- | First width/2,
Float ->
-- | Second width/2, should be biggest
Float ->
-- | Third width, should be smallest, possibly negative
Float ->
Room
roomTwistCross x y z =
let ps =
[ map
toV2
[ (x, negate $ z + 20)
, (x, x)
, (z, y)
, (z -20, x)
, (z, negate $ z + 20)
]
, rectNSWE (x -5) 0 0 (x -5)
]
corner =
defaultRoom
{ _rmPolys = ps
, _rmLinks = [toBothLnk (V2 z (y -20), pi / 2)]
, _rmPath = mempty
, _rmPmnts = [mntLS iShape (V2 x x) (V3 (x -20) (x -20) 70)]
, _rmBound = map (expandPolyCorners 10) ps
}
in (foldr1 combineRooms $ map (\r -> moveRoomBy (V2 0 0, r) corner) [0, pi / 2, pi, 3 * pi / 2])
{ _rmName = "twistCross"
}
in (foldr1 combineRooms $ map (\r -> moveRoomBy (V2 0 0, r) corner) [0,pi/2,pi,3*pi/2])
{_rmName = "twistCross" }
src/Dodge/Room/Branch.hs
+13 -15
View File
@@ -1,28 +1,26 @@
{-
Collections of rooms that branch into multiple paths.
-}
module Dodge.Room.Branch
where
--import Geometry
--import Dodge.LevelGen.Data
import Dodge.Data
module Dodge.Room.Branch where
import Control.Monad.State
import Dodge.Cleat
import Dodge.Data.GenWorld
import Dodge.Room.Door
import Dodge.Room.Link
import Dodge.Room.Procedural
--import Dodge.LevelGen.Data
import Dodge.Tree
import Control.Monad.State
import System.Random
branchRectWith :: RandomGen g => State g (Tree Room) -> State g (Tree Room)
branchRectWith :: RandomGen g => State g (Tree Room) -> State g (Tree Room)
branchRectWith t = do
x <- state $ randomR (100,200)
y <- state $ randomR (100,200)
x <- state $ randomR (100, 200)
y <- state $ randomR (100, 200)
b <- t
rt <- shuffleLinks $ roomRectAutoLinks x y
return $ Node rt
[ pure $ cleatOnward door
, treeFromTrunk [door] b
]
return $
Node
rt
[ pure $ cleatOnward door
, treeFromTrunk [door] b
]
src/Dodge/Room/Breather.hs
+1 -1
View File
@@ -1,6 +1,6 @@
module Dodge.Room.Breather where
import Dodge.Data
import Dodge.Data.GenWorld
import Dodge.Item
import Dodge.Room.Containing
import Dodge.Tree
src/Dodge/Room/CheckConsistency.hs
+3 -4
View File
@@ -1,7 +1,6 @@
module Dodge.Room.CheckConsistency
where
--import Dodge.LevelGen.Data
import Dodge.Data
module Dodge.Room.CheckConsistency where
import Dodge.Data.GenWorld
import Dodge.Graph
import Dodge.RoomLink
src/Dodge/Room/Containing.hs
+33 -30
View File
@@ -1,57 +1,60 @@
--{-# LANGUAGE TupleSections #-}
module Dodge.Room.Containing where
import Dodge.Data
import Dodge.Cleat
import Dodge.Data.GenWorld
import Dodge.Item.Display
import Dodge.Tree
import Dodge.LevelGen.Data
import Dodge.PlacementSpot
import RandomHelp
import Dodge.Room.Procedural
import Dodge.Room.Pillar
import Dodge.Room.Tanks
import Dodge.Room.Link
import Dodge.Room.Ngon
import Dodge.Cleat
import LensHelp
import Dodge.Room.Pillar
import Dodge.Room.Procedural
import Dodge.Room.Tanks
import Dodge.Tree
import Geometry
--import Dodge.Item.Equipment
import LensHelp
import RandomHelp
roomsContaining :: RandomGen g => [Creature] -> [Item] -> State g (MetaTree Room String)
roomsContaining crs its = tToBTree str <$> roomsContaining' crs its
where
str = "roomsContaining "++ concatMap _crName crs ++ concatMap (head . itemDisplay) its
str = "roomsContaining " ++ concatMap _crName crs ++ concatMap (head . itemDisplay) its
roomsContaining' :: RandomGen g => [Creature] -> [Item] -> State g (Tree Room)
roomsContaining' crs its = do
endroom <- join $ takeOne
[ roomPillarsSquare <&> rmPmnts ++.~ crsItmsUnused crs its
, randomFourCornerRoomCrsIts crs its
, tanksRoom crs its
, tanksPipesRoom <&> rmPmnts ++.~ crsItmsUnused crs its
, roomPillarsContaining crs its
, roomPillarsPassage <&> rmPmnts ++.~ crsItmsUnused crs its
]
endroom <-
join $
takeOne
[ roomPillarsSquare <&> rmPmnts ++.~ crsItmsUnused crs its
, randomFourCornerRoomCrsIts crs its
, tanksRoom crs its
, tanksPipesRoom <&> rmPmnts ++.~ crsItmsUnused crs its
, roomPillarsContaining crs its
, roomPillarsPassage <&> rmPmnts ++.~ crsItmsUnused crs its
]
return (pure $ cleatOnward endroom)
roomPillarsContaining :: RandomGen g => [Creature] -> [Item] -> State g Room
roomPillarsContaining crs itms = do
(w,wn) <- takeOne [(240,2),(340,3)]
(h,hn) <- takeOne [(240,2),(340,3)]
(w, wn) <- takeOne [(240, 2), (340, 3)]
(h, hn) <- takeOne [(240, 2), (340, 3)]
roomPillars 30 w h wn hn <&> rmPmnts .++~ crsItmsUnused crs itms
crsItmsUnused :: [Creature] -> [Item] -> [Placement]
crsItmsUnused crs itms = map (\it -> sps0 (PutFlIt it) & plSpot .~ anyUnusedSpot) itms
++ map (\cr -> sps0 (PutCrit cr) & plSpot .~ unusedSpotAwayFromLink 50) crs
crsItmsUnused crs itms =
map (\it -> sps0 (PutFlIt it) & plSpot .~ anyUnusedSpot) itms
++ map (\cr -> sps0 (PutCrit cr) & plSpot .~ unusedSpotAwayFromLink 50) crs
pedestalRoom :: RandomGen g => Item -> State g Room
pedestalRoom it = do
let flit = PutFlIt it
x <- state $ randomR (150,250)
ngon <- state $ randomR (5,9)
r <- takeOne
[ shuffleLinks =<< (centerVaultRoom x x 50 <&> rmPmnts .:~ sps0 flit)
, shuffleLinks $ roomRectAutoLinks (2*x) (2*x) & rmPmnts .:~ sPS (V2 x x) 0 flit
, shuffleLinks $ roomNgon ngon x & rmPmnts .:~ sps0 flit
]
x <- state $ randomR (150, 250)
ngon <- state $ randomR (5, 9)
r <-
takeOne
[ shuffleLinks =<< (centerVaultRoom x x 50 <&> rmPmnts .:~ sps0 flit)
, shuffleLinks $ roomRectAutoLinks (2 * x) (2 * x) & rmPmnts .:~ sPS (V2 x x) 0 flit
, shuffleLinks $ roomNgon ngon x & rmPmnts .:~ sps0 flit
]
r <&> rmName .++~ "ped-"
src/Dodge/Room/Corridor.hs
+103 -88
View File
@@ -1,118 +1,133 @@
{-# LANGUAGE TupleSections #-}
module Dodge.Room.Corridor where
import Data.Tile
--import Dodge.LevelGen.Data
import Dodge.Data
import Dodge.RoomLink
--import Dodge.Room.Foreground
import Dodge.Data.GenWorld
import Dodge.Default.Room
--import Dodge.LevelGen.Data
--import Dodge.LightSources.Lamp
import Dodge.Placement.Instance
import Dodge.PlacementSpot
import Dodge.RoomLink
import Geometry
import Tile
--import Data.Bifunctor
{- | First exit due north, two other exits at angles next to this.
Entrance from south. -}
Entrance from south.
-}
corridor :: Room
corridor = defaultRoom
{ _rmPolys = [poly]
, _rmLinks = lnks'
--, _rmPath = foldMap (doublePairSet . (,) (V2 20 60) . fst) lnks
, _rmPath = foldMap (doublePairSet . (,) (V2 20 60)) [V2 20 70,V2 20 10]
, _rmPmnts = [ spanLightI (V2 0 39.5) (V2 40 39.5) ]
, _rmBound = [ rectNSWE 50 30 (-5) 45 ]
, _rmFloor = Tiled [makeTileFromPoly poly 2]
, _rmRandPSs = [psRandRanges (10,30) (30,60) (0,2*pi)]
, _rmName = "Corridor"
}
where
corridor =
defaultRoom
{ _rmPolys = [poly]
, _rmLinks = lnks'
, --, _rmPath = foldMap (doublePairSet . (,) (V2 20 60) . fst) lnks
_rmPath = foldMap (doublePairSet . (,) (V2 20 60)) [V2 20 70, V2 20 10]
, _rmPmnts = [spanLightI (V2 0 39.5) (V2 40 39.5)]
, _rmBound = [rectNSWE 50 30 (-5) 45]
, _rmFloor = Tiled [makeTileFromPoly poly 2]
, _rmRandPSs = [psRandRanges (10, 30) (30, 60) (0, 2 * pi)]
, _rmName = "Corridor"
}
where
poly = rectNSWE 80 0 0 40
lnks' =
[uncurry outLink (V2 20 70 , 0)
,uncurry outLink (V2 20 70 , pi/6)
,uncurry outLink (V2 20 70 , negate $ pi/6)
,uncurry inLink (V2 20 10 , pi)
[ uncurry outLink (V2 20 70, 0)
, uncurry outLink (V2 20 70, pi / 6)
, uncurry outLink (V2 20 70, negate $ pi / 6)
, uncurry inLink (V2 20 10, pi)
]
keyholeCorridor :: Room
keyholeCorridor = corridor
{ _rmPath = mempty
, _rmPmnts =
[ midWall $ rectNSWE top bot 15 0
, midWall $ rectNSWE top bot 40 25]
}
keyholeCorridor =
corridor
{ _rmPath = mempty
, _rmPmnts =
[ midWall $ rectNSWE top bot 15 0
, midWall $ rectNSWE top bot 40 25
]
}
where
top = 65
bot = 15
corridorN :: Room
corridorN = defaultRoom
{ _rmPolys = [rectNSWE 80 0 0 40
]
, _rmLinks = lnks
, _rmPath = pth
, _rmPmnts = []
, _rmBound = [ rectNSWE 50 30 0 40 ]
, _rmName = "corridorN"
}
where lnks = [uncurry outLink (V2 20 70 ,0)
,uncurry inLink (V2 20 10 ,pi)
]
pth = doublePairSet (V2 20 70,V2 20 10)
corridorN =
defaultRoom
{ _rmPolys =
[ rectNSWE 80 0 0 40
]
, _rmLinks = lnks
, _rmPath = pth
, _rmPmnts = []
, _rmBound = [rectNSWE 50 30 0 40]
, _rmName = "corridorN"
}
where
lnks =
[ uncurry outLink (V2 20 70, 0)
, uncurry inLink (V2 20 10, pi)
]
pth = doublePairSet (V2 20 70, V2 20 10)
corridorWallN :: Room
corridorWallN = defaultRoom
{ _rmPolys = [rectNSWE 70 0 0 40
]
, _rmLinks = lnks
, _rmPath = pth
, _rmPmnts = []
, _rmBound = [ rectNSWE 50 30 0 40 ]
}
where
lnks = [uncurry outLink(V2 20 70 ,0)
,uncurry inLink(V2 20 10 ,pi)
]
pth = doublePairSet (V2 20 70,V2 20 10)
corridorWallN =
defaultRoom
{ _rmPolys =
[ rectNSWE 70 0 0 40
]
, _rmLinks = lnks
, _rmPath = pth
, _rmPmnts = []
, _rmBound = [rectNSWE 50 30 0 40]
}
where
lnks =
[ uncurry outLink (V2 20 70, 0)
, uncurry inLink (V2 20 10, pi)
]
pth = doublePairSet (V2 20 70, V2 20 10)
-- this should be combined with tWest
tEast :: Room
tEast = defaultRoom
{ _rmPolys = [rectNSWE 80 0 (-20) 20
,rectNSWE 80 40 (-40) 40
]
, _rmLinks = lnks'
, _rmPath = foldMap (doublePairSet . (,) (V2 0 60) . fst) lnks
, _rmPmnts = []
, _rmBound = [ rectNSWE 70 10 0 40 ]
, _rmName = "tEast"
}
where
tEast =
defaultRoom
{ _rmPolys =
[ rectNSWE 80 0 (-20) 20
, rectNSWE 80 40 (-40) 40
]
, _rmLinks = lnks'
, _rmPath = foldMap (doublePairSet . (,) (V2 0 60) . fst) lnks
, _rmPmnts = []
, _rmBound = [rectNSWE 70 10 0 40]
, _rmName = "tEast"
}
where
lnks =
[(V2 30 60, (-pi/2)::Float)
,(V2 (-30) 60, pi/2 )
,(V2 0 10, pi )
[ (V2 30 60, (- pi / 2) :: Float)
, (V2 (-30) 60, pi / 2)
, (V2 0 10, pi)
]
lnks' =
[uncurry outLink (V2 30 60,-pi/2)
,uncurry outLink (V2 (-30) 60,pi/2)
,uncurry inLink (V2 0 10,pi)
[ uncurry outLink (V2 30 60, - pi / 2)
, uncurry outLink (V2 (-30) 60, pi / 2)
, uncurry inLink (V2 0 10, pi)
]
tWest :: Room
tWest = defaultRoom
{ _rmPolys = [rectNSWE 80 0 (-20) 20
,rectNSWE 80 40 (-40) 40
]
, _rmLinks = lnks
, _rmPath = foldMap (doublePairSet . (V2 0 60 ,) . _rlPos) lnks
, _rmPmnts = []
, _rmBound = [ rectNSWE 70 10 0 40 ]
, _rmName = "tWest"
}
where
tWest =
defaultRoom
{ _rmPolys =
[ rectNSWE 80 0 (-20) 20
, rectNSWE 80 40 (-40) 40
]
, _rmLinks = lnks
, _rmPath = foldMap (doublePairSet . (V2 0 60,) . _rlPos) lnks
, _rmPmnts = []
, _rmBound = [rectNSWE 70 10 0 40]
, _rmName = "tWest"
}
where
lnks =
[outLink (V2 (-30) 60) ( pi/2)
,outLink (V2 30 60) (-pi/2)
,inLink (V2 0 10) pi
[ outLink (V2 (-30) 60) (pi / 2)
, outLink (V2 30 60) (- pi / 2)
, inLink (V2 0 10) pi
]
src/Dodge/Room/Door.hs
+34 -32
View File
@@ -1,42 +1,44 @@
{- Rooms that connect other rooms, blocking sight. -}
module Dodge.Room.Door
where
import Geometry
import Dodge.RoomLink
import Dodge.Data
import Dodge.Default.Room
import Dodge.Default.Door
import Dodge.Placement.Instance
import Color
module Dodge.Room.Door where
import Color
import Data.Maybe
import Dodge.Data.GenWorld
import Dodge.Default.Door
import Dodge.Default.Room
import Dodge.Placement.Instance
import Dodge.RoomLink
import Geometry
door :: Room
door = defaultRoom
{ _rmPolys = [rectNSWE 40 0 0 40]
, _rmLinks = lnks
, _rmPath = doublePairSet (V2 20 35,V2 20 5)
-- door extends into side walls (for shadows as rendered 12/03)
, _rmPmnts = [putAutoDoor (V2 0 20) (V2 40 20)]
, _rmName = "autoDoor"
, _rmBound = [rectNSWE 21 19 0 40]
}
where
lnks = [uncurry outLink (V2 20 35,0)
,uncurry inLink (V2 20 5,pi)
door =
defaultRoom
{ _rmPolys = [rectNSWE 40 0 0 40]
, _rmLinks = lnks
, _rmPath = doublePairSet (V2 20 35, V2 20 5)
, -- door extends into side walls (for shadows as rendered 12/03)
_rmPmnts = [putAutoDoor (V2 0 20) (V2 40 20)]
, _rmName = "autoDoor"
, _rmBound = [rectNSWE 21 19 0 40]
}
where
lnks =
[ uncurry outLink (V2 20 35, 0)
, uncurry inLink (V2 20 5, pi)
]
triggerDoorRoom :: Int -> Room
triggerDoorRoom inplid = defaultRoom
{ _rmPolys = [rectNSWE 40 0 0 40]
, _rmLinks = [uncurry outLink (V2 20 35,0) ,uncurry inLink(V2 20 5,pi) ]
, _rmPath = doublePairSet (V2 20 35,V2 20 5)
, _rmInPmnt = [InPlacement f inplid]
, _rmName = "triggerDoorRoom"
-- door extends into side walls (for shadows as rendered 12/03/21)
-- note no bounds
}
where
f (pmnt:_) = putDoubleDoor DoorObstacle (switchWallCol red) (cond pmnt) (V2 0 20) (V2 40 20) 2
triggerDoorRoom inplid =
defaultRoom
{ _rmPolys = [rectNSWE 40 0 0 40]
, _rmLinks = [uncurry outLink (V2 20 35, 0), uncurry inLink (V2 20 5, pi)]
, _rmPath = doublePairSet (V2 20 35, V2 20 5)
, _rmInPmnt = [InPlacement f inplid]
, _rmName = "triggerDoorRoom"
-- door extends into side walls (for shadows as rendered 12/03/21)
-- note no bounds
}
where
f (pmnt : _) = putDoubleDoor DoorObstacle (switchWallCol red) (cond pmnt) (V2 0 20) (V2 40 20) 2
f _ = error "tried to put a door using an empty placement list"
cond pmnt = WdTrig $ fromJust (_plMID pmnt)
src/Dodge/Room/Foreground.hs
+153 -113
View File
@@ -1,60 +1,65 @@
--{-# LANGUAGE TupleSections #-}
module Dodge.Room.Foreground
( thinHighBar
, putShape
, girder
, girderZ
, girderV
, girderV'
, barPP
, highDiagonalMesh
, highMesh
) where
import Dodge.Data
import Picture
import Geometry
import Shape
import Quaternion
import Bound
module Dodge.Room.Foreground (
thinHighBar,
putShape,
girder,
girderZ,
girderV,
girderV',
barPP,
highDiagonalMesh,
highMesh,
) where
--import Dodge.Data.ForegroundShape
import Dodge.Default.Foreground
import Bound
import Control.Lens
import Data.List
import Data.Maybe
import Control.Lens
import Dodge.Data.GenWorld
import Dodge.Default.ForegroundShape
import Geometry
import Picture
import Quaternion
import Shape
import ShapePicture
import Streaming
import qualified Streaming.Prelude as S
highMesh
:: Point2
-> Point2
-> Float -- ^ width
-> Picture
highMesh pa pb w = highDiagonalMesh pa pb w 20
<> highDiagonalMesh (pa +.+ w *.* normalizeV (vNormal (pb -.- pa))) pa (dist pa pb) 20
highMesh ::
Point2 ->
Point2 ->
-- | width
Float ->
Picture
highMesh pa pb w =
highDiagonalMesh pa pb w 20
<> highDiagonalMesh (pa +.+ w *.* normalizeV (vNormal (pb -.- pa))) pa (dist pa pb) 20
highDiagonalMesh
:: Point2
-> Point2
-> Float -- ^ width
-> Float -- ^ vertical distance between lines
-> Picture
highDiagonalMesh pa pb w d = setDepth 100 $ pictures $
map (thickLine 2 . tflat2) (diagonalLinesRect pb pa w d (3*pi/4))
++
map (thickLine 2 . tflat2) (diagonalLinesRect pb pc (negate h) d (pi/4))
highDiagonalMesh ::
Point2 ->
Point2 ->
-- | width
Float ->
-- | vertical distance between lines
Float ->
Picture
highDiagonalMesh pa pb w d =
setDepth 100 $
pictures $
map (thickLine 2 . tflat2) (diagonalLinesRect pb pa w d (3 * pi / 4))
++ map (thickLine 2 . tflat2) (diagonalLinesRect pb pc (negate h) d (pi / 4))
where
pc = pb +.+ w *.* normalizeV (vNormal (pb -.- pa))
h = dist pa pb
diagonalLinesRect
:: Point2
-> Point2
-> Float -- ^ width
-> Float -- ^ vertical distance between lines
-> Float
-> [(Point2,Point2)]
diagonalLinesRect ::
Point2 ->
Point2 ->
-- | width
Float ->
-- | vertical distance between lines
Float ->
Float ->
[(Point2, Point2)]
diagonalLinesRect pa pb w d ang = zip lhsPoints $ map findDiPoint lhsPoints
where
xVec = negate w *.* vNormal (normalizeV $ pb -.- pa)
@@ -62,11 +67,13 @@ diagonalLinesRect pa pb w d ang = zip lhsPoints $ map findDiPoint lhsPoints
pax = pa +.+ xVec
pbx = pb +.+ xVec
lhsPoints = divideLineExact d (pa -.- yN) (pb +.+ yN)
findDiPoint p = head . sortOn (dist p) $ catMaybes
[intersectLineLine' p (p +.+ diVec) pax pbx
,intersectSegLine pa pax p (p +.+ diVec)
,intersectSegLine pb pbx p (p +.+ diVec)
]
findDiPoint p =
head . sortOn (dist p) $
catMaybes
[ intersectLineLine' p (p +.+ diVec) pax pbx
, intersectSegLine pa pax p (p +.+ diVec)
, intersectSegLine pb pbx p (p +.+ diVec)
]
yN = d * 0.5 *.* normalizeV (pa -.- pb)
thinHighBar :: Float -> Point2 -> Point2 -> Shape
@@ -82,8 +89,12 @@ thinHighBar = highBar 3
--thickHighBar = highBar 5
highBar :: Float -> Float -> Point2 -> Point2 -> Shape
highBar thickness h x y = translateSHz h $ colorSH orange $ upperPrismPoly thickness
[x +.+ n, y +.+ n, y -.- n, x -.- n]
highBar thickness h x y =
translateSHz h $
colorSH orange $
upperPrismPoly
thickness
[x +.+ n, y +.+ n, y -.- n, x -.- n]
where
n = 0.5 * thickness *.* normalizeV (vNormal (y -.- x))
@@ -95,16 +106,23 @@ highBar thickness h x y = translateSHz h $ colorSH orange $ upperPrismPoly thick
-- n2 = 1.25 *.* normalizeV (vNormal (y -.- x))
-- n = 2.5 *.* normalizeV (vNormal (y -.- x))
girderZ
:: Float -- ^ height
-> Float -- ^ distance between cross bars
-> Float -- ^ width
-> Point2 -> Point2 -> Shape
girderZ h d w x y = colorSH red $ mconcat $
[ thinHighBar h xt yt
, thinHighBar h xb yb
]
<> zipWith (thinHighBar (h- 1)) ps qs
girderZ ::
-- | height
Float ->
-- | distance between cross bars
Float ->
-- | width
Float ->
Point2 ->
Point2 ->
Shape
girderZ h d w x y =
colorSH red $
mconcat $
[ thinHighBar h xt yt
, thinHighBar h xb yb
]
<> zipWith (thinHighBar (h - 1)) ps qs
where
n = w *.* normalizeV (vNormal $ y -.- x)
xb = x +.+ n
@@ -115,10 +133,12 @@ girderZ h d w x y = colorSH red $ mconcat $
qs = tail $ divideLineExact d xt yt
putShape :: Shape -> PSType
putShape sh = PutForeground $ defaultForeground
& fsPos .~ m
& fsRad .~ radBounds bnds
& fsSPic .~ noPic (uncurryV translateSHf (-m) sh)
putShape sh =
PutForeground $
defaultForeground
& fsPos .~ m
& fsRad .~ radBounds bnds
& fsSPic .~ noPic (uncurryV translateSHf (- m) sh)
where
bnds = shapeBounds sh
m = midBounds bnds
@@ -126,43 +146,56 @@ putShape sh = PutForeground $ defaultForeground
shapePoints :: Shape -> Stream (Of Point2) Identity ()
shapePoints = S.each . concatMap (map (stripZ . _svPos) . _shVs)
shapeBounds :: Shape -> (Float,Float,Float,Float)
shapeBounds = fromMaybe (0,0,0,0) . boundPoints . shapePoints
shapeBounds :: Shape -> (Float, Float, Float, Float)
shapeBounds = fromMaybe (0, 0, 0, 0) . boundPoints . shapePoints
midBounds :: (Float,Float,Float,Float) -> Point2
midBounds (n,s,e,w) = V2 ((n + s)/2) ((e + w)/2)
midBounds :: (Float, Float, Float, Float) -> Point2
midBounds (n, s, e, w) = V2 ((n + s) / 2) ((e + w) / 2)
radBounds :: (Float, Float,Float,Float) -> Float
radBounds (n,s,e,w) = max (n-s) (e-w) / 2
radBounds :: (Float, Float, Float, Float) -> Float
radBounds (n, s, e, w) = max (n - s) (e - w) / 2
girderV'
:: Float -- ^ height
-> Float -- ^ distance between cross bars
-> Float -- ^ width
-> Point2 -> Point2 -> ForegroundShape
girderV' h d w x y = defaultForeground
& fsPos .~ m
& fsRad .~ dist m x
& fsSPic .~ noPic sh
girderV' ::
-- | height
Float ->
-- | distance between cross bars
Float ->
-- | width
Float ->
Point2 ->
Point2 ->
ForegroundShape
girderV' h d w x y =
defaultForeground
& fsPos .~ m
& fsRad .~ dist m x
& fsSPic .~ noPic sh
where
m = midPoint x y
x' = x - m
y' = y - m
sh = thinHighBar h (x' -.- n) (x' +.+ n)
<> thinHighBar h (y' -.- n) (y' +.+ n)
<> girderV h d w x' y'
sh =
thinHighBar h (x' -.- n) (x' +.+ n)
<> thinHighBar h (y' -.- n) (y' +.+ n)
<> girderV h d w x' y'
n = min (w + 10) 20 *.* vNormal (normalizeV (x' -.- y'))
girderV
:: Float -- ^ height
-> Float -- ^ distance between cross bars
-> Float -- ^ width
-> Point2 -> Point2 -> Shape
girderV h d w x y = mconcat $
[ thinHighBar h xt yt
, thinHighBar h xb yb
]
<> zipWith (thinHighBar (h- 1)) ps qs
girderV ::
-- | height
Float ->
-- | distance between cross bars
Float ->
-- | width
Float ->
Point2 ->
Point2 ->
Shape
girderV h d w x y =
mconcat $
[ thinHighBar h xt yt
, thinHighBar h xb yb
]
<> zipWith (thinHighBar (h - 1)) ps qs
where
n = w *.* normalizeV (vNormal $ y -.- x)
xb = x +.+ n
@@ -170,22 +203,28 @@ girderV h d w x y = mconcat $
xt = x -.- n
yt = y -.- n
ps = evenDouble $ divideLineExact d xb yb
qs = head qs' : evenDouble(tail qs')
qs = head qs' : evenDouble (tail qs')
where
qs' = divideLineExact d xt yt
evenDouble (a:_:xs) = a:a:evenDouble xs
evenDouble (a : _ : xs) = a : a : evenDouble xs
evenDouble xs = xs
girder
:: Float -- ^ height
-> Float -- ^ distance between cross bars
-> Float -- ^ width
-> Point2 -> Point2 -> Shape
girder h d w x y = mconcat $
[ thinHighBar h xt yt
, thinHighBar h xb yb
]
<> zipWith (thinHighBar (h- 1)) ps qs
girder ::
-- | height
Float ->
-- | distance between cross bars
Float ->
-- | width
Float ->
Point2 ->
Point2 ->
Shape
girder h d w x y =
mconcat $
[ thinHighBar h xt yt
, thinHighBar h xb yb
]
<> zipWith (thinHighBar (h - 1)) ps qs
where
n = w *.* normalizeV (vNormal $ y -.- x)
xb = x +.+ n
@@ -196,11 +235,12 @@ girder h d w x y = mconcat $
qs = divideLineExact d xt yt
barPP :: Float -> Point3 -> Point3 -> Shape
barPP w a b
barPP w a b
| a == b = mempty
| otherwise = prismPoly
(map ((+.+.+ a) . rotateToZ z1 . addZ 0) $ polyCirc 2 w)
(map ((+.+.+ b) . rotateToZ z1 . addZ 0) $ polyCirc 2 w)
| otherwise =
prismPoly
(map ((+.+.+ a) . rotateToZ z1 . addZ 0) $ polyCirc 2 w)
(map ((+.+.+ b) . rotateToZ z1 . addZ 0) $ polyCirc 2 w)
where
z1 = b -.-.- a
@@ -210,11 +250,11 @@ barPP w a b
-- (map ((+.+.+ b) . rotateToZ z1 . addZ 0) $ polyCirc 4 w)
-- where
-- z1 = b -.-.- a
--tankTopPipe :: Shape
--tankTopPipe = colorSH orange $
--tankTopPipe = colorSH orange $
-- upperPrismPoly 31 (polyCirc 4 20)
-- <> prismPoly
-- <> prismPoly
-- (map (addZ 41) $ polyCirc 4 5)
-- (map (addZ 31) $ polyCirc 4 20)
---- <> pipePP 5 (V3 0 0 51) (V3 0 0 41)
src/Dodge/Room/Girder.hs
+7 -6
View File
@@ -1,19 +1,20 @@
module Dodge.Room.Girder where
import Dodge.Data
import RandomHelp
import Color
import Dodge.Data.GenWorld
import Dodge.Room.Foreground
import Dodge.Room.Modify.Girder
import Color
import RandomHelp
addRandomGirderEW :: RandomGen g => Room -> State g Room
addRandomGirderEW rm = do
hgshape <- takeOne [girder 96 20 10, girderZ 96 20 10, girderV 96 20 10]
lgshape <- takeOne [girder 60 20 10, girderZ 60 20 10, girderV 60 20 10]
addgird <- takeOne [ addGirderNS' hgshape black , addGirderNS' lgshape red ]
addgird <- takeOne [addGirderNS' hgshape black, addGirderNS' lgshape red]
addgird rm
addRandomGirderFrom :: RandomGen g => CardinalPoint -> Int -> Room -> State g Room
addRandomGirderFrom cp i rm = do
(h,col) <- takeOne [(96,black),(60,red)]
gtype <- takeOne [girder,girderZ,girderV]
(h, col) <- takeOne [(96, black), (60, red)]
gtype <- takeOne [girder, girderZ, girderV]
return $ addGirderFrom cp i (gtype h 20 10) col rm
src/Dodge/Room/GlassLesson.hs
+56 -46
View File
@@ -1,59 +1,69 @@
--{-# LANGUAGE TupleSections #-}
module Dodge.Room.GlassLesson where
import Dodge.Cleat
import Dodge.Annotation.Data
import Dodge.RoomLink
import Dodge.Creature
import Dodge.LevelGen.Data
import Dodge.Data
import RandomHelp
import Dodge.Default.Wall
import Dodge.Tree
import Dodge.Placement.Instance
--import Dodge.LevelGen.Data
import Dodge.Room.Procedural
import Dodge.Room.Corridor
import Dodge.Room.Link
import Dodge.Room.Door
import Geometry
import LensHelp
import qualified Data.Set as S
--import Control.Monad.Loops
import Dodge.Annotation.Data
import Dodge.Cleat
import Dodge.Creature
import Dodge.Data.GenWorld
import Dodge.Default.Wall
import Dodge.LevelGen.Data
import Dodge.Placement.Instance
import Dodge.Room.Corridor
import Dodge.Room.Door
import Dodge.Room.Link
import Dodge.Room.Procedural
import Dodge.RoomLink
import Dodge.Tree
import Geometry
import LensHelp
import RandomHelp
glassLesson :: RandomGen g => State g (Tree Room)
glassLesson = do
i <- takeOne [1,2,3]
i <- takeOne [1, 2, 3]
corridors <- replicateM i $ shuffleLinks corridor
return $ Node botRoom
[ pure $ door & rmConnectsTo .~ fromWest North 1
, uppers
, treeFromPost ( (door & rmConnectsTo .~ S.member (OnEdge East))
: corridors) $ cleatOnward door]
where
fromWest edge i s = OnEdge edge `S.member` s && FromEdge West i `S.member` s
return $
Node
botRoom
[ pure $ door & rmConnectsTo .~ fromWest North 1
, uppers
, treeFromPost
( (door & rmConnectsTo .~ S.member (OnEdge East)) :
corridors
)
$ cleatOnward door
]
where
fromWest edge i s = OnEdge edge `S.member` s && FromEdge West i `S.member` s
uppers = Node (door & rmConnectsTo .~ fromWest North 0) [pure topRoom]
botRoom = roomRect 200 200 1 1
& rmPmnts .~ botplmnts
& rmLinks %~ setInLinksByType (OnEdge West)
topRoom = roomRect 200 200 1 1
& rmPmnts .~ topplmnts
& rmLinks %~ setInLinks (fromWest South 0 . _rlType)
botplmnts =
[sPS (V2 0 0) 0 $ PutWall (rectNSWE 200 0 90 110) defaultCrystalWall
,sPS (V2 50 100) 0 $ PutCrit miniGunCrit
,RandomPlacement $ takeOne
[ spanLightI (V2 160 (-20)) (V2 160 220)
, mntLS vShape (V2 180 200) (V3 160 180 50)
]
botRoom =
roomRect 200 200 1 1
& rmPmnts .~ botplmnts
& rmLinks %~ setInLinksByType (OnEdge West)
topRoom =
roomRect 200 200 1 1
& rmPmnts .~ topplmnts
& rmLinks %~ setInLinks (fromWest South 0 . _rlType)
botplmnts =
[ sPS (V2 0 0) 0 $ PutWall (rectNSWE 200 0 90 110) defaultCrystalWall
, sPS (V2 50 100) 0 $ PutCrit miniGunCrit
, RandomPlacement $
takeOne
[ spanLightI (V2 160 (-20)) (V2 160 220)
, mntLS vShape (V2 180 200) (V3 160 180 50)
]
]
topplmnts =
[windowLine (V2 100 200) (V2 100 0)
,sPS (V2 50 100) 0 $ PutCrit miniGunCrit
,RandomPlacement $ takeOne
[ spanLightI (V2 160 (-20)) (V2 160 220)
, mntLS vShape (V2 180 200) (V3 160 180 50)
]
topplmnts =
[ windowLine (V2 100 200) (V2 100 0)
, sPS (V2 50 100) 0 $ PutCrit miniGunCrit
, RandomPlacement $
takeOne
[ spanLightI (V2 160 (-20)) (V2 160 220)
, mntLS vShape (V2 180 200) (V3 160 180 50)
]
]
glassLessonRunPast :: RandomGen g => State g MTRS
glassLessonRunPast = glassLesson >>= rToOnward "glassLessonRunPast" . f
where
src/Dodge/Room/LasTurret.hs
+114 -97
View File
@@ -1,68 +1,70 @@
--{-# LANGUAGE TupleSections #-}
module Dodge.Room.LasTurret where
import Dodge.LevelGen.Data
import qualified Data.Set as S
import Dodge.Cleat
import Dodge.Data.GenWorld
import Dodge.Default.Room
import Dodge.Item.Consumable
import Dodge.LevelGen.Data
import Dodge.Placement.Instance
import Dodge.Placement.Instance.Analyser
import Dodge.PlacementSpot
import Dodge.Data
import Dodge.Tree
import Dodge.RoomLink
import Dodge.Room.Door
import Dodge.Room.Corridor
import Dodge.Room.Door
import Dodge.Room.Link
import Dodge.Room.Ngon
import Dodge.Room.SensorDoor
--import Dodge.Room.Foreground
import Dodge.RoomLink
import Dodge.Tree
import Dodge.Wire
import Dodge.Placement.Instance
import Dodge.Placement.Instance.Analyser
import Dodge.Default.Room
import Dodge.Item.Consumable
import Geometry
import LensHelp
import RandomHelp
import qualified Data.Set as S
--import Data.Maybe
cenLasTur :: Room
cenLasTur = roomNgon 8 200 & rmPmnts .~
[ putLasTurret 0.02
, heightWallPS (resetPLUse $ rprBoolShift (const . isInLnk) (shiftInBy 100)) 30 covershape
, mntLightLnkCond $ rprBool $ const . isInLnk
]
cenLasTur =
roomNgon 8 200 & rmPmnts
.~ [ putLasTurret 0.02
, heightWallPS (resetPLUse $ rprBoolShift (const . isInLnk) (shiftInBy 100)) 30 covershape
, mntLightLnkCond $ rprBool $ const . isInLnk
]
where
covershape = rectNSWE 10 (-10) (-20) 20
lightSensInsideDoor :: Int -> Room -> Room
lightSensInsideDoor outplid rm = rm
& rmPmnts .++~
[ psPt atFstLnkOut (PutForeground $ floorWire (V2 20 0) (V2 20 (-100)))
, psPt atFstLnkOut (PutForeground $ floorWire (V2 0 (-100)) (V2 20 (-100)))
, psPt atFstLnkOut (PutForeground $ verticalWire (V2 20 0) 0 80)
]
& rmOutPmnt .~ [OutPlacement (sensAboveDoor LASERING 10 (atFstLnkOutShiftInward 100)) outplid]
lightSensInsideDoor outplid rm =
rm
& rmPmnts
.++~ [ psPt atFstLnkOut (PutForeground $ floorWire (V2 20 0) (V2 20 (-100)))
, psPt atFstLnkOut (PutForeground $ floorWire (V2 0 (-100)) (V2 20 (-100)))
, psPt atFstLnkOut (PutForeground $ verticalWire (V2 20 0) 0 80)
]
& rmOutPmnt .~ [OutPlacement (sensAboveDoor LASERING 10 (atFstLnkOutShiftInward 100)) outplid]
lightSensByDoor :: Int -> Room -> Room
lightSensByDoor outplid rm = rm
& rmPmnts .++~
[ psPt atFstLnkOut $ PutForeground $ verticalWire (V2 20 0) 0 80
, heightWallPS (atNthLnkOutShiftInward 1 100) 30 covershape
, heightWallPS (atFstLnkOutShiftInward 100) 30 covershape
]
& rmOutPmnt .~ [OutPlacement (sensAboveDoor LASERING 20 (atFstLnkOutShiftBy sensorshift)) outplid]
lightSensByDoor outplid rm =
rm
& rmPmnts
.++~ [ psPt atFstLnkOut $ PutForeground $ verticalWire (V2 20 0) 0 80
, heightWallPS (atNthLnkOutShiftInward 1 100) 30 covershape
, heightWallPS (atFstLnkOutShiftInward 100) 30 covershape
]
& rmOutPmnt .~ [OutPlacement (sensAboveDoor LASERING 20 (atFstLnkOutShiftBy sensorshift)) outplid]
where
covershape = rectNSWE 10 (-10) (-20) 20
sensorshift (p,a) = (p +.+ rotateV a (V2 60 (-20)), a)
sensorshift (p, a) = (p +.+ rotateV a (V2 60 (-20)), a)
keyCardRoomRunPast :: RandomGen g => Int -> Int -> State g (MetaTree Room String)
keyCardRoomRunPast keyid rmid = do
cenroom <- shuffleLinks $ keyCardAnalyserByDoor keyid rmid $ roomNgon 6 200
let doorroom = triggerDoorRoom rmid
rToOnward "keyCardRoomRunPast" $
treeFromTrunk [door] $ Node cenroom
[ treeFromPost [doorroom] (cleatOnward door)
, treeFromPost [door] (cleatLabel rmid corridor)
]
treeFromTrunk [door] $
Node
cenroom
[ treeFromPost [doorroom] (cleatOnward door)
, treeFromPost [door] (cleatLabel rmid corridor)
]
keyCardAnalyserByDoor :: Int -> Int -> Room -> Room
keyCardAnalyserByDoor keyid = analyserByDoor (RequireEquipment (HELD (KEYCARD keyid)))
@@ -71,78 +73,91 @@ healthAnalyserByDoor :: Int -> Room -> Room
healthAnalyserByDoor = analyserByDoor (RequireHealth 1100)
analyserByDoor :: ProximityRequirement -> Int -> Room -> Room
analyserByDoor proxreq outplid rm = rm
& rmPmnts .++~
[ psPt atFstLnkOut $ PutForeground $ verticalWire (V2 20 0) 0 80
]
& rmOutPmnt .~
[OutPlacement
(analyser proxreq
(atFstLnkOutShiftBy (\(p,a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a)))
(atFstLnkOutShiftBy sensorshift)
)
outplid]
analyserByDoor proxreq outplid rm =
rm
& rmPmnts
.++~ [ psPt atFstLnkOut $ PutForeground $ verticalWire (V2 20 0) 0 80
]
& rmOutPmnt
.~ [ OutPlacement
( analyser
proxreq
(atFstLnkOutShiftBy (\(p, a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a)))
(atFstLnkOutShiftBy sensorshift)
)
outplid
]
where
sensorshift (p,a) = (p +.+ rotateV a (V2 30 (-10)), a)
sensorshift (p, a) = (p +.+ rotateV a (V2 30 (-10)), a)
healthTest :: RandomGen g => Int -> State g (Tree Room)
healthTest n = do
cenroom <- shuffleLinks $ healthAnalyserByDoor n $ roomNgon 8 200
return $ treePost
[ door
, corridor & rmPmnts .:~ spNoID (PS 20 0) (PutFlIt (medkit 100))
, cenroom
, triggerDoorRoom n
, cleatOnward door
]
return $
treePost
[ door
, corridor & rmPmnts .:~ spNoID (PS 20 0) (PutFlIt (medkit 100))
, cenroom
, triggerDoorRoom n
, cleatOnward door
]
lasSensorTurretTest :: RandomGen g => Int -> State g (MetaTree Room String)
lasSensorTurretTest n = do
cenroom <- shuffleLinks $ lightSensInsideDoor n cenLasTur
rToOnward "lasSensorTurretTest" $ treePost
[ door, cenroom, triggerDoorRoom n, cleatOnward door]
rToOnward "lasSensorTurretTest" $
treePost
[door, cenroom, triggerDoorRoom n, cleatOnward door]
lasCenSensEdge :: RandomGen g => Int -> State g (MetaTree Room String)
lasCenSensEdge n = do
cenroom <- shuffleLinks $ lightSensByDoor n cenLasTur
let doorroom = triggerDoorRoom n
rToOnward "lasCenSensEdge"
$ treeFromTrunk [ door] $ Node cenroom
[ treePost [ doorroom, cleatOnward door ]
, treePost [ door, cleatLabel 0 corridor]
]
rToOnward "lasCenSensEdge" $
treeFromTrunk [door] $
Node
cenroom
[ treePost [doorroom, cleatOnward door]
, treePost [door, cleatLabel 0 corridor]
]
lasTunnel :: RandomGen g => Float -> State g Room
lasTunnel y = do
extraPlmnts <- takeOne
[ [ midWall ( rectNSWE 115 90 0 60)
, midWall ( rectNSWE 65 40 (-40) 25)
extraPlmnts <-
takeOne
[
[ midWall (rectNSWE 115 90 0 60)
, midWall (rectNSWE 65 40 (-40) 25)
]
,
[ midWall (rectNSWE 125 100 0 25)
, midWall (rectNSWE 80 40 (-40) 0)
, midWall (rectNSWE 80 40 25 60)
]
]
, [ midWall ( rectNSWE 125 100 0 25)
, midWall ( rectNSWE 80 40 (-40) 0)
, midWall ( rectNSWE 80 40 25 60)
]
]
return defaultRoom
{ _rmPolys = polys
, _rmBound = polys
, _rmLinks =
[outLink (V2 20 (190 + y)) (1.5* pi)
,outLink (V2 0 (190 + y)) (0.5* pi)
, inLink (V2 (-40) 20) (0.5* pi)
, inLink (V2 60 20) (1.5* pi)
, inLink (V2 10 0) pi
]
, _rmPmnts = [putLasTurret 0.005 & plSpot .~ PS (V2 10 (240+y)) (1.5*pi)
--, midWall (rectNSEW 65 40 0 25)
, mntLS vShape (V2 60 145) (V3 40 125 90)
, mntLS vShape (V2 (-40) 145) (V3 (-20) 125 90)
]
++ extraPlmnts
, _rmName = "lasTunnel" ++ show y
}
return
defaultRoom
{ _rmPolys = polys
, _rmBound = polys
, _rmLinks =
[ outLink (V2 20 (190 + y)) (1.5 * pi)
, outLink (V2 0 (190 + y)) (0.5 * pi)
, inLink (V2 (-40) 20) (0.5 * pi)
, inLink (V2 60 20) (1.5 * pi)
, inLink (V2 10 0) pi
]
, _rmPmnts =
[ putLasTurret 0.005 & plSpot .~ PS (V2 10 (240 + y)) (1.5 * pi)
, --, midWall (rectNSEW 65 40 0 25)
mntLS vShape (V2 60 145) (V3 40 125 90)
, mntLS vShape (V2 (-40) 145) (V3 (-20) 125 90)
]
++ extraPlmnts
, _rmName = "lasTunnel" ++ show y
}
where
polys = [rectNSWE (250+y) 0 0 20
polys =
[ rectNSWE (250 + y) 0 0 20
, rectNSWE 145 0 (-40) 60
]
@@ -150,9 +165,11 @@ lasTunnel y = do
lasTunnelRunPast :: RandomGen g => Float -> State g (MetaTree Room String)
lasTunnelRunPast y = do
r <- lasTunnel y
r1 <- takeOne [door,corridor]
r2 <- takeOne [door,corridor]
rToOnward "lasTunnelRunPast" $ Node r
[ pure $ cleatOnward r1
, return (cleatLabel 0 $ r2 & rmConnectsTo .~ S.member InLink)
]
r1 <- takeOne [door, corridor]
r2 <- takeOne [door, corridor]
rToOnward "lasTunnelRunPast" $
Node
r
[ pure $ cleatOnward r1
, return (cleatLabel 0 $ r2 & rmConnectsTo .~ S.member InLink)
]
src/Dodge/Room/Link.hs
+67 -63
View File
@@ -3,31 +3,29 @@ Link pairs determine where rooms can attach to each other; each pair consists
of a position and a rotation.
The last link in the list is considered the incoming link, the other links are
the outgoing links. -}
module Dodge.Room.Link
( shiftRoomShiftToLink
, moveRoomBy
, shiftLinkBy
, doRoomShift
, shuffleLinks
, restrictRMInLinksPD
) where
import Dodge.ShiftPoint
--import Dodge.Placement.PlaceSpot
import Dodge.Placement.Shift
--import Dodge.LevelGen.Data
import Dodge.Data
import RandomHelp
import Geometry
import Data.Tile
import Dodge.RoomLink
module Dodge.Room.Link (
shiftRoomShiftToLink,
moveRoomBy,
shiftLinkBy,
doRoomShift,
shuffleLinks,
restrictRMInLinksPD,
) where
import Control.Lens
import qualified Data.Set as S
import Data.Tile
import Dodge.Data.GenWorld
import Dodge.Placement.Shift
import Dodge.RoomLink
import Dodge.ShiftPoint
import Geometry
import RandomHelp
restrictRMInLinksPD :: ((Point2,Float) -> Bool) -> Room -> Room
restrictRMInLinksPD :: ((Point2, Float) -> Bool) -> Room -> Room
restrictRMInLinksPD f = rmLinks %~ restrictLinkType InLink f
{- Shuffle the order of all links of a room randomly.
{- Shuffle the order of all links of a room randomly.
- Note this does not change their types. -}
shuffleLinks :: RandomGen g => Room -> State g Room
shuffleLinks = rmLinks %%~ shuffle
@@ -36,57 +34,63 @@ doRoomShift :: Room -> Room
doRoomShift rm = shiftRoomBy (_rmShift rm) rm & rmShift .~ _rmShift rm
-- NOTE placements, when placed, will be shifted by the value _rmShift
shiftRoomBy :: (Point2,Float) -> Room -> Room
shiftRoomBy shift r = r
& rmPolys %~ fmap (map (shiftPointBy shift))
& rmLinks %~ fmap (shiftLinkBy shift)
& rmPath %~ S.map (shiftPathBy shift)
& rmBound %~ fmap (map (shiftPointBy shift))
& rmShift %~ shiftPosDirBy shift
& rmFloor . tiles %~ map
( (tilePoly %~ map (shiftPointBy shift))
. (tileZero %~ shiftPointBy shift )
. (tileX %~ shiftPointBy shift )
)
& rmViewpoints %~ map (shiftPointBy shift)
moveRoomBy :: (Point2,Float) -> Room -> Room
moveRoomBy shift r = r
& rmPolys %~ fmap (map (shiftPointBy shift))
& rmLinks %~ fmap (shiftLinkBy shift)
& rmPath %~ S.map (shiftPathBy shift)
& rmBound %~ fmap (map (shiftPointBy shift))
& rmPmnts %~ map (shiftPlacement shift)
& rmFloor . tiles %~ map
( (tilePoly %~ map (shiftPointBy shift))
. (tileZero %~ shiftPointBy shift )
. (tileX %~ shiftPointBy shift )
)
& rmViewpoints %~ map (shiftPointBy shift)
& rmPos %~ map ( ( rpPos %~ shiftPointBy shift ) . (rpDir +~ snd shift) )
shiftRoomShiftToLink :: (Point2,Float) -> (Point2,Float) -> Room -> Room
shiftRoomShiftToLink l inlink r
= shiftRoomShiftBy l
. shiftRoomShiftBy (V2 0 0 , pi-a)
$ shiftRoomShiftBy (V2 0 0 -.- p , 0)
shiftRoomBy :: (Point2, Float) -> Room -> Room
shiftRoomBy shift r =
r
where
(p,a) = inlink
& rmPolys %~ fmap (map (shiftPointBy shift))
& rmLinks %~ fmap (shiftLinkBy shift)
& rmPath %~ S.map (shiftPathBy shift)
& rmBound %~ fmap (map (shiftPointBy shift))
& rmShift %~ shiftPosDirBy shift
& rmFloor . tiles
%~ map
( (tilePoly %~ map (shiftPointBy shift))
. (tileZero %~ shiftPointBy shift)
. (tileX %~ shiftPointBy shift)
)
& rmViewpoints %~ map (shiftPointBy shift)
moveRoomBy :: (Point2, Float) -> Room -> Room
moveRoomBy shift r =
r
& rmPolys %~ fmap (map (shiftPointBy shift))
& rmLinks %~ fmap (shiftLinkBy shift)
& rmPath %~ S.map (shiftPathBy shift)
& rmBound %~ fmap (map (shiftPointBy shift))
& rmPmnts %~ map (shiftPlacement shift)
& rmFloor . tiles
%~ map
( (tilePoly %~ map (shiftPointBy shift))
. (tileZero %~ shiftPointBy shift)
. (tileX %~ shiftPointBy shift)
)
& rmViewpoints %~ map (shiftPointBy shift)
& rmPos %~ map ((rpPos %~ shiftPointBy shift) . (rpDir +~ snd shift))
shiftRoomShiftToLink :: (Point2, Float) -> (Point2, Float) -> Room -> Room
shiftRoomShiftToLink l inlink r =
shiftRoomShiftBy l
. shiftRoomShiftBy (V2 0 0, pi - a)
$ shiftRoomShiftBy
(V2 0 0 -.- p, 0)
r
where
(p, a) = inlink
-- NOTE placements, when placed, will be shifted by the value _rmShift
shiftRoomShiftBy :: (Point2,Float) -> Room -> Room
shiftRoomShiftBy :: (Point2, Float) -> Room -> Room
shiftRoomShiftBy shift = rmShift %~ shiftPosDirBy shift
shiftPosDirBy :: (Point2,Float) -> (Point2,Float) -> (Point2,Float)
shiftPosDirBy (pos,rot) (p,r) = (shiftPointBy (pos,rot) p, r + rot)
shiftPosDirBy :: (Point2, Float) -> (Point2, Float) -> (Point2, Float)
shiftPosDirBy (pos, rot) (p, r) = (shiftPointBy (pos, rot) p, r + rot)
shiftLinkBy :: (Point2,Float) -> RoomLink -> RoomLink
shiftLinkBy (pos,rot) = overLnkPosDir f
shiftLinkBy :: (Point2, Float) -> RoomLink -> RoomLink
shiftLinkBy (pos, rot) = overLnkPosDir f
where
f (p,r) = (shiftPointBy (pos,rot) p, r + rot)
f (p, r) = (shiftPointBy (pos, rot) p, r + rot)
shiftPathBy :: (Point2,Float) -> (Point2,Point2) -> (Point2,Point2)
shiftPathBy s (p1,p2) = sp1 `seq` sp2 `seq` (sp1, sp2)
shiftPathBy :: (Point2, Float) -> (Point2, Point2) -> (Point2, Point2)
shiftPathBy s (p1, p2) = sp1 `seq` sp2 `seq` (sp1, sp2)
where
sp1 = shiftPointBy s p1
sp2 = shiftPointBy s p2
src/Dodge/Room/LongDoor.hs
+121 -92
View File
@@ -1,77 +1,83 @@
--{-# LANGUAGE TupleSections #-}
{- | Rooms containing long doors, probably with a big reveal behind them.
-}
-- | Rooms containing long doors, probably with a big reveal behind them.
module Dodge.Room.LongDoor where
import Dodge.Terminal
import Dodge.Data
import Dodge.Default.Door
import Dodge.LevelGen.Switch
import Data.Maybe
import qualified Data.Set as S
import Dodge.Cleat
import Dodge.RoomLink
import Dodge.Tree
import Dodge.Creature
import Dodge.Data.GenWorld
import Dodge.Default.Door
import Dodge.Default.Room
import Dodge.LevelGen.Data
import Dodge.LightSource
import Dodge.Placement.Instance
import Dodge.PlacementSpot
import Dodge.Room.Link
import Dodge.Room.Door
import Dodge.Room.Link
import Dodge.Room.Procedural
--import Dodge.Layout.Tree.Either
--import Dodge.LevelGen.Data
import Dodge.LevelGen.Switch
import RandomHelp
import Dodge.Creature.Inanimate
import Dodge.Creature
import Dodge.LightSource
import Picture
import Dodge.RoomLink
import Dodge.Terminal
import Dodge.Tree
import Geometry
import LensHelp
--import Shape
import Picture
import RandomHelp
import qualified Data.Set as S
import Data.Maybe
twinSlowDoorRoom
:: Float -- ^ Half width
-> Float -- ^ Half height
-> Float -- ^ Inner width
-> Room
twinSlowDoorRoom w h x = defaultRoom
{ _rmPolys = ps
, _rmLinks = map (uncurry outLink)
[ (V2 w (h/2) , negate $ pi/2)
, (V2 (-w) (h/2) , pi/2) ]
++ [uncurry inLink (V2 0 (-h), pi) ]
, _rmPath = mempty
, _rmPmnts =
[ pContID (PS (V2 0 (h-5)) pi) ( PutButton $ makeButton col NoWorldEffect)
$ \btid -> jsps0J (PutSlideDr (thedoor btid) thewall DoorObstacle 1 (V2 x 1) (V2 x h))
$ ps0 (PutSlideDr (thedoor btid) thewall DoorObstacle 1 (V2 (-x) 1) (V2 (-x) h))
$ \did -> jps0' (PutLS (lsColPos (V3 0.75 0 0) (V3 0 (h-1) lampheight)))
$ \lspl -> jsps0 $ PutProp $ addColorChange (fromJust $ _plMID lspl) did $ lampCoverWhen (WdBlDoorMoving did) (V2 0 (h-1)) lampheight
]
, _rmBound = ps
, _rmName = "twinSlowDoorRoom"
, _rmViewpoints = [V2 0 h]
}
twinSlowDoorRoom ::
-- | Half width
Float ->
-- | Half height
Float ->
-- | Inner width
Float ->
Room
twinSlowDoorRoom w h x =
defaultRoom
{ _rmPolys = ps
, _rmLinks =
map
(uncurry outLink)
[ (V2 w (h / 2), negate $ pi / 2)
, (V2 (- w) (h / 2), pi / 2)
]
++ [uncurry inLink (V2 0 (- h), pi)]
, _rmPath = mempty
, _rmPmnts =
[ pContID (PS (V2 0 (h -5)) pi) (PutButton $ makeButton col NoWorldEffect) $
\btid -> jsps0J (PutSlideDr (thedoor btid) thewall DoorObstacle 1 (V2 x 1) (V2 x h)) $
ps0 (PutSlideDr (thedoor btid) thewall DoorObstacle 1 (V2 (- x) 1) (V2 (- x) h)) $
\did -> jps0' (PutLS (lsColPos (V3 0.75 0 0) (V3 0 (h -1) lampheight))) $
\lspl -> jsps0 $ PutProp $ addColorChange (fromJust $ _plMID lspl) did $ lampCoverWhen (WdBlDoorMoving did) (V2 0 (h -1)) lampheight
]
, _rmBound = ps
, _rmName = "twinSlowDoorRoom"
, _rmViewpoints = [V2 0 h]
}
where
thewall = switchWallCol red
wlSpeed = 0.5
addColorChange lsid drid = over prUpdate $ PropUpdateAnd $ PropUpdateIf (WdBlDoorMoving drid)
(PropUpdateLS lsid (PrWdLsSetColor (V3 8 0 0)))
(PropUpdateLS lsid (PrWdLsSetColor 0.7))
addColorChange lsid drid =
over prUpdate $
PropUpdateAnd $
PropUpdateIf
(WdBlDoorMoving drid)
(PropUpdateLS lsid (PrWdLsSetColor (V3 8 0 0)))
(PropUpdateLS lsid (PrWdLsSetColor 0.7))
lampheight = 41
ps =
[rectNSWE h 0 (-w) w
,rectNSWE 20 (-h) (negate x) x
ps =
[ rectNSWE h 0 (- w) w
, rectNSWE 20 (- h) (negate x) x
]
thedoor btid = defaultDoor
& drSpeed .~ wlSpeed
& drTrigger .~ WdBlBtNotOff btid
thedoor btid =
defaultDoor
& drSpeed .~ wlSpeed
& drTrigger .~ WdBlBtNotOff btid
col = dim $ dim $ bright red
twinSlowDoorChasers :: RandomGen g => State g Room
twinSlowDoorChasers = do
ps <- takeN 4 $ [ V2 x y | x <- [-65,65], y <- [20,40 .. 180] ]
ps <- takeN 4 $ [V2 x y | x <- [-65, 65], y <- [20, 40 .. 180]]
let plmnts = map (\p -> sPS p 0 $ PutCrit chaseCrit) ps
return $ twinSlowDoorRoom 80 200 40 & rmPmnts %~ (plmnts ++)
@@ -81,59 +87,79 @@ southPillarsRoom x y h = addSouthPillars x h (roomRectAutoLinks x y)
addSouthPillars :: RandomGen g => Float -> Float -> Room -> State g Room
addSouthPillars x h r = do
let pillarsa = []
pillarsb = concat [putBlockRect (i*x/5-20) (i*x/5+20) (h/2-20) (h/2+20) | i <- [1..4] ]
pillarsc = concat [putBlockRect (i*x/3-20) (i*x/3+20) (h/2-20) (h/2+20) | i <- [1,2] ]
pillarsb = concat [putBlockRect (i * x / 5 -20) (i * x / 5 + 20) (h / 2 -20) (h / 2 + 20) | i <- [1 .. 4]]
pillarsc = concat [putBlockRect (i * x / 3 -20) (i * x / 3 + 20) (h / 2 -20) (h / 2 + 20) | i <- [1, 2]]
pillars <- takeOne [pillarsa, pillarsb, pillarsc]
return $ r & rmPmnts .++~ pillars
addButtonSlowDoor :: RandomGen g => Float -> Float -> Room -> State g Room
addButtonSlowDoor x h rm = do
shuffleLinks $ setOutLinksPD aboveH $ setInLinksPD belowH $ rm
& rmPmnts .++~ [butDoor , theterminal]
& rmBound .:~ openDoorBound
shuffleLinks $
setOutLinksPD aboveH $
setInLinksPD belowH $
rm
& rmPmnts .++~ [butDoor, theterminal]
& rmBound .:~ openDoorBound
where
theterminal = putMessageTerminal terminalColor (simpleTermMessage themessage)
& plSpot .~ rprBoolShift (isUnusedLnkType InLink) (shiftByV2 (V2 0 (-10)))
themessage =
["WARNING:"
,"LARGE BIOMASS DETECTED"
theterminal =
putMessageTerminal terminalColor (simpleTermMessage themessage)
& plSpot .~ rprBoolShift (isUnusedLnkType InLink) (shiftByV2 (V2 0 (-10)))
themessage =
[ "WARNING:"
, "LARGE BIOMASS DETECTED"
]
openDoorBound = reverse $ rectNSWE (h + 5) (h - 5) (3*x/2) (-x/2)
openDoorBound = reverse $ rectNSWE (h + 5) (h - 5) (3 * x / 2) (- x / 2)
belowH y = (sndV2 . fst) y < h - 40
aboveH y = (sndV2 . fst) y > h + 40
amountedlight dr xoff mpl = Just . moveLSThen (WdP2fDoorPosition (fromJust $ _plMID dr))
(V3 15 xoff 89) (aShape (V2 15 0) (V3 15 xoff 90))
$ \plls plpr -> Just $ ptCont (PutWorldUpdate (const $ setmount dr plls plpr))
$ const mpl
setmount pldr plls plpr = cWorld . doors . ix (fromJust $ _plMID pldr) . drMounts .++~
[MountedLS (fromJust $ _plMID plls), MountedProp (fromJust $ _plMID plpr)]
amountedlight dr xoff mpl = Just
. moveLSThen
(WdP2fDoorPosition (fromJust $ _plMID dr))
(V3 15 xoff 89)
(aShape (V2 15 0) (V3 15 xoff 90))
$ \plls plpr ->
Just $
ptCont (PutWorldUpdate (const $ setmount dr plls plpr)) $
const mpl
setmount pldr plls plpr =
cWorld . doors . ix (fromJust $ _plMID pldr) . drMounts
.++~ [MountedLS (fromJust $ _plMID plls), MountedProp (fromJust $ _plMID plpr)]
-- TODO make the height of this light source and of other mounted lights
-- be taken from a single consistent source
thewall = switchWallCol red
butDoor = putLitButOnPos col
butDoor = putLitButOnPos
col
(rprBool (isUnusedLnkType InLink))
$ \btplmnt -> Just $ putDoubleDoorThen DoorObstacle thewall (WdBlBtNotOff $ fromJust $ _plMID btplmnt)
30 (V2 0 h) (V2 x h) 2
$ \dr1 dr2 ->
amountedlight dr1 50
$ amountedlight dr1 (-50)
$ amountedlight dr2 50
$ amountedlight dr2 (-50)
Nothing
$ \btplmnt -> Just $
putDoubleDoorThen
DoorObstacle
thewall
(WdBlBtNotOff $ fromJust $ _plMID btplmnt)
30
(V2 0 h)
(V2 x h)
2
$ \dr1 dr2 ->
amountedlight dr1 50 $
amountedlight dr1 (-50) $
amountedlight dr2 50 $
amountedlight
dr2
(-50)
Nothing
col = dim $ light red
slowDoorRoom :: RandomGen g => State g Room
slowDoorRoom = do
x <- state $ randomR (400,800)
y <- state $ randomR (400,800)
h <- state $ randomR (200,min (y-100) 500)
x <- state $ randomR (400, 800)
y <- state $ randomR (400, 800)
h <- state $ randomR (200, min (y -100) 500)
let n = 25
xs <- replicateM n $ state $ randomR (10,x-10)
ys <- replicateM n $ state $ randomR (h+20,y)
rs <- replicateM n $ state $ randomR (0,2*pi)
xs <- replicateM n $ state $ randomR (10, x -10)
ys <- replicateM n $ state $ randomR (h + 20, y)
rs <- replicateM n $ state $ randomR (0, 2 * pi)
let ps = zipWith V2 xs ys
xs' <- replicateM 5 $ state $ randomR (10,x-10)
ys' <- replicateM 5 $ state $ randomR (h+20,y)
xs' <- replicateM 5 $ state $ randomR (10, x -10)
ys' <- replicateM 5 $ state $ randomR (h + 20, y)
let crits = zipWith (\p r -> sPS p r randC1) ps rs
barrels = zipWith (\x' y' -> sPS (V2 x' y') 0 $ PutCrit explosiveBarrel) xs' ys'
proom <- southPillarsRoom x y h
@@ -142,7 +168,10 @@ slowDoorRoom = do
slowDoorRoomRunPast :: RandomGen g => State g (MetaTree Room String)
slowDoorRoomRunPast = do
r <- slowDoorRoom
rToOnward "slowDoorRoomRunPast" $ treeFromTrunk [ door] $ Node r
[ pure $ cleatOnward door
, return (cleatLabel 0 $ door & rmConnectsTo .~ S.member InLink)
]
rToOnward "slowDoorRoomRunPast" $
treeFromTrunk [door] $
Node
r
[ pure $ cleatOnward door
, return (cleatLabel 0 $ door & rmConnectsTo .~ S.member InLink)
]
src/Dodge/Room/LongRoom.hs
+45 -46
View File
@@ -1,57 +1,56 @@
--{-# LANGUAGE TupleSections #-}
module Dodge.Room.LongRoom where
import Dodge.Cleat
import Dodge.RoomLink
import Dodge.Tree
--import Dodge.Default.Room
import Dodge.Default.Wall
import Dodge.LevelGen.Data
import Dodge.Data
import Dodge.Placement.Instance
import Dodge.Room.Link
import Dodge.Room.Door
import Dodge.Room.Corridor
import Dodge.Room.Procedural
--import Dodge.Layout.Tree.Either
--import Dodge.LevelGen.Data
--import Dodge.LevelGen.Switch
import RandomHelp
import Dodge.Creature.Inanimate
import Dodge.Creature
--import Dodge.LightSource
--import Picture
import Geometry
import LensHelp
import Data.Tile
import qualified Data.Set as S
--import qualified Data.IntMap as IM
import Data.Tile
import Dodge.Cleat
import Dodge.Creature
import Dodge.Data.GenWorld
import Dodge.Default.Wall
import Dodge.LevelGen.Data
import Dodge.Placement.Instance
import Dodge.Room.Corridor
import Dodge.Room.Door
import Dodge.Room.Link
import Dodge.Room.Procedural
import Dodge.RoomLink
import Dodge.Tree
import Geometry
import LensHelp
import RandomHelp
longRoom :: RandomGen g => State g Room
longRoom = do
h <- state $ randomR (1500,1500)
h <- state $ randomR (1500, 1500)
let w = 75
let wlsNSEWs wln wls listew = [sps0 $ PutWall (rectNSWE wln wls wallw walle) defaultCrystalWall
| (wallw,walle) <- listew ]
let ws = wlsNSEWs (h-35) (h-135) [(-10,10) , (15,35) , (40,60) , (65,85)]
let wsDefense = wlsNSEWs 95 70 [(0,25) , (50,75) ]
brlN <- state $ randomR (0,5)
brlOffsets <- replicateM brlN $ randInRect (w-20) 900
let brls = [ sPS (p +.+ V2 10 200) 0 $ PutCrit explosiveBarrel | p <- brlOffsets ]
rm <- shuffleLinks $ roomRect w (h+70) 1 1 & rmPolys .++~ [rectNSWE h (h-165) (-45) (w+45)]
& rmFloor .~ InheritFloor
return $ restrictInLinks (\x -> (sndV2 . fst) x < 40)
$ restrictOutLinks (\x -> (sndV2 . fst) x > h * 0.75)
$ rm & rmPmnts .~ ws ++ brls ++ wsDefense ++
[sPS (V2 crx (h-25)) 0 $ PutCrit longCrit
| crx <- [12.5,37.5,62.5] ] ++
[sPS (V2 25 lampy ) 0 putLamp | lampy <- [20,h-10] ]
let wlsNSEWs wln wls listew =
[ sps0 $ PutWall (rectNSWE wln wls wallw walle) defaultCrystalWall
| (wallw, walle) <- listew
]
let ws = wlsNSEWs (h -35) (h -135) [(-10, 10), (15, 35), (40, 60), (65, 85)]
let wsDefense = wlsNSEWs 95 70 [(0, 25), (50, 75)]
brlN <- state $ randomR (0, 5)
brlOffsets <- replicateM brlN $ randInRect (w -20) 900
let brls = [sPS (p +.+ V2 10 200) 0 $ PutCrit explosiveBarrel | p <- brlOffsets]
rm <-
shuffleLinks $
roomRect w (h + 70) 1 1 & rmPolys .++~ [rectNSWE h (h -165) (-45) (w + 45)]
& rmFloor .~ InheritFloor
return $
restrictInLinks (\x -> (sndV2 . fst) x < 40) $
restrictOutLinks (\x -> (sndV2 . fst) x > h * 0.75) $
rm & rmPmnts .~ ws ++ brls ++ wsDefense
++ [ sPS (V2 crx (h -25)) 0 $ PutCrit longCrit
| crx <- [12.5, 37.5, 62.5]
]
++ [sPS (V2 25 lampy) 0 putLamp | lampy <- [20, h -10]]
longRoomRunPast :: RandomGen g => State g (MetaTree Room String)
longRoomRunPast = do
r <- longRoom
rToOnward "longRoomRunPast"
$ treeFromTrunk [door] $ Node r
[ pure $ cleatOnward door
, treePost [ corridor & rmConnectsTo .~ S.member InLink, cleatLabel 0 door ]
]
rToOnward "longRoomRunPast" $
treeFromTrunk [door] $
Node
r
[ pure $ cleatOnward door
, treePost [corridor & rmConnectsTo .~ S.member InLink, cleatLabel 0 door]
]
src/Dodge/Room/Modify/Girder.hs
+137 -87
View File
@@ -1,76 +1,90 @@
module Dodge.Room.Modify.Girder
( addGirderLights
, addGirderFrom
, addHighGirder
, addHighGirder'
, addGirderEW
, addGirderNS
, addGirderNS'
) where
--import Dodge.Data
import Dodge.LevelGen.Data
import Dodge.Data
--import Dodge.Room.Procedural
import Dodge.Room.Foreground
--import Dodge.Room.RoadBlock
--import Dodge.Placement.Instance
--import Dodge.Placement.TopDecoration
import Dodge.PlacementSpot
import Dodge.LightSource
--import Padding
import Color
import Shape
import LensHelp
import Geometry
import RandomHelp
module Dodge.Room.Modify.Girder (
addGirderLights,
addGirderFrom,
addHighGirder,
addHighGirder',
addGirderEW,
addGirderNS,
addGirderNS',
) where
import Data.Maybe
import Color
import Data.List (nub)
import Data.Maybe
import qualified Data.Set as S
import Dodge.Data.GenWorld
import Dodge.LevelGen.Data
import Dodge.LightSource
import Dodge.PlacementSpot
import Dodge.Room.Foreground
import Geometry
import LensHelp
import RandomHelp
import Shape
addGirderNS :: RandomGen g => (Point2 -> Point2 -> Shape) -> Color -> Room -> State g Room
addGirderNS shapef col room = do
let nwestlnks = length $ filter ((OnEdge North `S.member`) . _rlType) $ _rmLinks room
girderPosOrder <- shuffle [1 .. nwestlnks - 2]
return $ room & rmPmnts .:~ foldr1 setFallback
(sps0 PutNothing : [ twoRoomPoss
(isUnusedLnkType (FromEdge West i))
(isUnusedLnkType (FromEdge West i))
$ \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2)
| i <- girderPosOrder]
)
return $
room & rmPmnts
.:~ foldr1
setFallback
( sps0 PutNothing :
[ twoRoomPoss
(isUnusedLnkType (FromEdge West i))
(isUnusedLnkType (FromEdge West i))
$ \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2)
| i <- girderPosOrder
]
)
addGirderFrom :: CardinalPoint -> Int -> (Point2 -> Point2 -> Shape) -> Color -> Room -> Room
addGirderFrom cp fromi shapef col = rmPmnts .:~ foldr1 setFallback
[ sps0 PutNothing
, twoRoomPoss rmposcond rmposcond
$ \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2) ]
addGirderFrom cp fromi shapef col =
rmPmnts
.:~ foldr1
setFallback
[ sps0 PutNothing
, twoRoomPoss rmposcond rmposcond $
\ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2)
]
where
rmposcond = isUnusedLnkType (FromEdge cp fromi)
-- | Allows girder to be on edge
addGirderNS' :: RandomGen g => (Point2 -> Point2 -> Shape) -> Color -> Room -> State g Room
addGirderNS' shapef col room = do
let nwestlnks = length $ filter ((OnEdge North `S.member`) . _rlType) $ _rmLinks room
girderPosOrder <- shuffle [0 .. nwestlnks - 1]
return $ room & rmPmnts .:~ foldr1 setFallback
(sps0 PutNothing : [ twoRoomPoss
(isUnusedLnkType (FromEdge West i))
(isUnusedLnkType (FromEdge West i))
$ \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2)
| i <- girderPosOrder]
)
return $
room & rmPmnts
.:~ foldr1
setFallback
( sps0 PutNothing :
[ twoRoomPoss
(isUnusedLnkType (FromEdge West i))
(isUnusedLnkType (FromEdge West i))
$ \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2)
| i <- girderPosOrder
]
)
addGirderEW :: RandomGen g => (Point2 -> Point2 -> Shape) -> Color -> Room -> State g Room
addGirderEW shapef col room = do
let nwestlnks = length $ filter ((OnEdge West `S.member`) . _rlType) $ _rmLinks room
girderPosOrder <- shuffle [1 .. nwestlnks - 2]
return $ room & rmPmnts .:~ foldr1 setFallback
(sps0 PutNothing :
[ twoRoomPoss
(isUnusedLnkType (FromEdge South i))
(isUnusedLnkType (FromEdge South i))
$ \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2)
| i <- girderPosOrder]
)
return $
room & rmPmnts
.:~ foldr1
setFallback
( sps0 PutNothing :
[ twoRoomPoss
(isUnusedLnkType (FromEdge South i))
(isUnusedLnkType (FromEdge South i))
$ \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2)
| i <- girderPosOrder
]
)
-- TODO add a central light to this, with mounted light fallback?
addGirder :: RandomGen g => (Point2 -> Point2 -> Shape) -> Color -> Room -> State g Room
@@ -80,14 +94,19 @@ addGirder shapef col room = do
nsgirds = girdson (FromEdge East) nslnks
ewgirds = girdson (FromEdge North) ewlnks
girders <- shuffle $ nsgirds ++ ewgirds
return $ room & rmPmnts .:~ foldr1 setFallback
(sps0 PutNothing : girders)
return $
room & rmPmnts
.:~ foldr1
setFallback
(sps0 PutNothing : girders)
where
girdson f numlnks = [ twoRoomPoss
girdson f numlnks =
[ twoRoomPoss
(isUnusedLnkType (f i))
(isUnusedLnkType (f i))
$ \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2)
| i <- [1 .. numlnks - 2] ]
$ \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2)
| i <- [1 .. numlnks - 2]
]
addGirder' :: RandomGen g => (Point2 -> Point2 -> Shape) -> Color -> Room -> State g Room
addGirder' shapef col room = do
@@ -96,41 +115,53 @@ addGirder' shapef col room = do
nsgirds = girdson (FromEdge East) nslnks
ewgirds = girdson (FromEdge North) ewlnks
girders <- shuffle $ nsgirds ++ ewgirds
return $ room & rmPmnts .:~ foldr1 setFallback
(sps0 PutNothing : girders)
return $
room & rmPmnts
.:~ foldr1
setFallback
(sps0 PutNothing : girders)
where
girdson f numlnks = [ twoRoomPoss
girdson f numlnks =
[ twoRoomPoss
(isUnusedLnkType (f i))
(isUnusedLnkType (f i))
$ \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2)
| i <- [0 .. numlnks - 1] ]
$ \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2)
| i <- [0 .. numlnks - 1]
]
addHighGirder :: RandomGen g => Room -> State g Room
addHighGirder r = do
gsize <- takeOne [(20,10),(30,10),(40,10),(30,15)]
hgshape <- takeOne $ map (\f -> uncurry (f 96) gsize)
[girder, girderZ, girderV]
gsize <- takeOne [(20, 10), (30, 10), (40, 10), (30, 15)]
hgshape <-
takeOne $
map
(\f -> uncurry (f 96) gsize)
[girder, girderZ, girderV]
addGirder hgshape black r
addHighGirder' :: RandomGen g => Room -> State g Room
addHighGirder' r = do
gsize <- takeOne [(20,10),(30,10),(40,10),(30,15)]
hgshape <- takeOne $ map (\f -> uncurry (f 96) gsize)
[girder, girderZ, girderV]
gsize <- takeOne [(20, 10), (30, 10), (40, 10), (30, 15)]
hgshape <-
takeOne $
map
(\f -> uncurry (f 96) gsize)
[girder, girderZ, girderV]
addGirder' hgshape black r
randomLightPositions :: RandomGen g => Room -> State g [(Int,Int)]
randomLightPositions :: RandomGen g => Room -> State g [(Int, Int)]
randomLightPositions rm = do
let rmtype = _rmType rm
xs <- shuffle [0.._numLinkEW rmtype]
ys <- shuffle [0.._numLinkNS rmtype]
xs <- shuffle [0 .. _numLinkEW rmtype]
ys <- shuffle [0 .. _numLinkNS rmtype]
let n = max (length xs) (length ys)
return $ take n $ zip (xs ++ xs) (ys ++ ys)
intsToPos :: Room -> (Int,Int) -> Point2
intsToPos rm (x,y) = V2
(20 + _linkGapEW rmtype * fromIntegral x)
(20 + _linkGapNS rmtype * fromIntegral y)
intsToPos :: Room -> (Int, Int) -> Point2
intsToPos rm (x, y) =
V2
(20 + _linkGapEW rmtype * fromIntegral x)
(20 + _linkGapNS rmtype * fromIntegral y)
where
rmtype = _rmType rm
@@ -149,15 +180,34 @@ addGirderLights rm = do
w = _rmWidth rmtype
h = _rmHeight rmtype
midw = wiToFloat rm midi
extragirderpos = nub $ map (\(wi,hi) -> (wi - midi, hi)) lpis
extragirders = mapMaybe (\(i,hi) -> case i of
x | x < 0 -> Just $ girderV' 96 20 10 (V2 (midw - 10) (hiToFloat rm hi))
(V2 0 (hiToFloat rm hi))
x | x > 0 -> Just $ girderV' 96 20 10 (V2 (midw + 10) (hiToFloat rm hi))
(V2 w (hiToFloat rm hi))
_ -> Nothing
) extragirderpos
return $ rm & rmPmnts .++~
(sps0 (PutForeground $ girderV' 96 20 10 (V2 midw 0) (V2 midw h))
: map (\p -> sps (PS p 0) (PutLS $ lsColPos 0.75 (V3 0 0 90))) lps
) ++ map (sps0 . PutForeground) extragirders
extragirderpos = nub $ map (\(wi, hi) -> (wi - midi, hi)) lpis
extragirders =
mapMaybe
( \(i, hi) -> case i of
x
| x < 0 ->
Just $
girderV'
96
20
10
(V2 (midw - 10) (hiToFloat rm hi))
(V2 0 (hiToFloat rm hi))
x
| x > 0 ->
Just $
girderV'
96
20
10
(V2 (midw + 10) (hiToFloat rm hi))
(V2 w (hiToFloat rm hi))
_ -> Nothing
)
extragirderpos
return $
rm & rmPmnts
.++~ ( sps0 (PutForeground $ girderV' 96 20 10 (V2 midw 0) (V2 midw h)) :
map (\p -> sps (PS p 0) (PutLS $ lsColPos 0.75 (V3 0 0 90))) lps
)
++ map (sps0 . PutForeground) extragirders
src/Dodge/Room/Ngon.hs
+26 -28
View File
@@ -1,36 +1,34 @@
module Dodge.Room.Ngon where
import Data.List
import Data.Maybe
import Data.Tile
import Dodge.Data.GenWorld
import Dodge.Default.Room
import Dodge.Placement.Instance
import Dodge.PlacementSpot
import Dodge.RoomLink
import Dodge.Default.Room
--import Dodge.LevelGen.Data
import Dodge.Data
import Dodge.Placement.Instance
--import Dodge.LevelGen.Data
import Geometry
import Tile
--import qualified Data.Set as S
--import Control.Monad.Loops
import Data.Maybe
import Data.List
roomNgon :: Int -> Float -> Room
roomNgon n x = defaultRoom
{ _rmPolys = [poly]
, _rmLinks = map toBothLnk lnks -- muout (init lnks) ++ muin[last lnks]
, _rmPath = mempty -- TODO
, _rmPmnts = [mntLightLnkCond $ resetPLUse $ rprBool $ const . isInLnk]
, _rmBound = [poly]
, _rmFloor = Tiled [makeTileFromPoly poly 9]
, _rmName = show n ++ "gon"
}
where
rot = 2*pi / fromIntegral n
rots = map ((rot *) . fromIntegral) [0..n-1]
poly = mapMaybe
(\(ra,rb) -> intersectLineLine' (rotateV ra bl) (rotateV ra br) (rotateV rb bl) (rotateV rb br))
$ loopPairs rots
bl = V2 x x
br = V2 (-x) x
lnks = sortOn ((\(V2 a b) -> (negate b,a)) . fst) $ map (\r -> (rotateV r (V2 0 x),r)) rots
roomNgon n x =
defaultRoom
{ _rmPolys = [poly]
, _rmLinks = map toBothLnk lnks -- muout (init lnks) ++ muin[last lnks]
, _rmPath = mempty -- TODO
, _rmPmnts = [mntLightLnkCond $ resetPLUse $ rprBool $ const . isInLnk]
, _rmBound = [poly]
, _rmFloor = Tiled [makeTileFromPoly poly 9]
, _rmName = show n ++ "gon"
}
where
rot = 2 * pi / fromIntegral n
rots = map ((rot *) . fromIntegral) [0 .. n -1]
poly =
mapMaybe
(\(ra, rb) -> intersectLineLine' (rotateV ra bl) (rotateV ra br) (rotateV rb bl) (rotateV rb br))
$ loopPairs rots
bl = V2 x x
br = V2 (- x) x
lnks = sortOn ((\(V2 a b) -> (negate b, a)) . fst) $ map (\r -> (rotateV r (V2 0 x), r)) rots
src/Dodge/Room/NoNeedWeapon.hs
+22 -24
View File
@@ -1,36 +1,34 @@
{- | Rooms that can be successfully tackled without having any items. -}
module Dodge.Room.NoNeedWeapon
( centerVaultExplosiveExit
) where
import Dodge.Data
import Dodge.Creature
--import Dodge.Creature.Inanimate
import Dodge.LevelGen.Data
import Dodge.Room.Procedural
--import Dodge.Room.Link
import RandomHelp
--import Dodge.LevelGen.Data
import Geometry.Data
-- | Rooms that can be successfully tackled without having any items.
module Dodge.Room.NoNeedWeapon (
centerVaultExplosiveExit,
) where
import Control.Lens
--import Control.Monad
import Dodge.Creature
import Dodge.Data.GenWorld
import Dodge.LevelGen.Data
import Dodge.Room.Procedural
import Geometry.Data
import RandomHelp
{- |
A room designed to be /passable/ with no weapons.
Highlights an issue: when trying to place next door rooms, if the level generation fails it will try a different link.
So if there are multiple such, we cannot assume that a given link will be chosen.
To solve this, here we delete unwanted links.
-}
centerVaultExplosiveExit
:: RandomGen g
=> State g Room
centerVaultExplosiveExit ::
RandomGen g =>
State g Room
centerVaultExplosiveExit = do
cr <- takeOne [miniGunCrit, autoCrit]
let extraPS =
[sPS (V2 0 110) 0 $ PutCrit explosiveBarrel
,sPS (V2 5 115) 0 $ PutCrit explosiveBarrel
,sPS (V2 0 120) 0 $ PutCrit explosiveBarrel
,sPS (V2 0 0) 0 $ PutCrit (cr & crState . csDropsOnDeath .~ DropAll)
let extraPS =
[ sPS (V2 0 110) 0 $ PutCrit explosiveBarrel
, sPS (V2 5 115) 0 $ PutCrit explosiveBarrel
, sPS (V2 0 120) 0 $ PutCrit explosiveBarrel
, sPS (V2 0 0) 0 $ PutCrit (cr & crState . csDropsOnDeath .~ DropAll)
]
centerVaultRoom 120 120 50 <&> rmPmnts %~ (extraPS ++)
--r <- centerVaultRoom 120 120 50 <&> rmPmnts %~ (extraPS ++)
--randomiseLinksBy shuffleTail r <&> rmOutLinks %~ take 2
--r <- centerVaultRoom 120 120 50 <&> rmPmnts %~ (extraPS ++)
--randomiseLinksBy shuffleTail r <&> rmOutLinks %~ take 2
src/Dodge/Room/Path.hs
+39 -40
View File
@@ -1,59 +1,58 @@
module Dodge.Room.Path
( gridPoints
, linksAndPath
, linksAndPath'
, makeGrid
, createPathGrid
, gridPoints''
)
where
--import Dodge.LevelGen.Data
import Dodge.Data
module Dodge.Room.Path (
gridPoints,
linksAndPath,
linksAndPath',
makeGrid,
createPathGrid,
gridPoints'',
) where
import qualified Control.Foldl as L
import Data.Function (on)
import Data.List
import Data.Maybe
import qualified Data.Set as S
import Dodge.Data.GenWorld
import Dodge.LevelGen.StaticWalls
import Dodge.RoomLink
import Geometry
import Grid
import Data.Function (on)
import Data.List
import Data.Maybe
import qualified Control.Foldl as L
import qualified Data.Set as S
createPathGrid :: Room -> Room
createPathGrid rm = rm
{ _rmPath = linksAndPath (map lnkPosDir $ _rmLinks rm) filterGrid }
createPathGrid rm =
rm
{ _rmPath = linksAndPath (map lnkPosDir $ _rmLinks rm) filterGrid
}
where
filterGrid = filter (\p -> pairInPolys (_rmPolys rm) p && testCrossWalls outerWalls p) grid
grid = fromMaybe [] $ shiftedGrid <$> minx <*> maxx <*> miny <*> maxy
outerWalls = foldr cutPoly [] $ _rmPolys rm
outerPoints = map fst outerWalls
(minx, maxx, miny, maxy) = L.fold theFold outerPoints
theFold = (,,,)
<$> L.premap fstV2 L.minimum
<*> L.premap fstV2 L.maximum
<*> L.premap sndV2 L.minimum
<*> L.premap sndV2 L.maximum
theFold =
(,,,)
<$> L.premap fstV2 L.minimum
<*> L.premap fstV2 L.maximum
<*> L.premap sndV2 L.minimum
<*> L.premap sndV2 L.maximum
linksAndPath :: [(Point2,Float)] -> [(Point2,Point2)] -> S.Set (Point2,Point2)
linksAndPath :: [(Point2, Float)] -> [(Point2, Point2)] -> S.Set (Point2, Point2)
linksAndPath lnks subpth = S.fromList subpth <> foldMap linkClosest lnks
where
linkClosest (p,_) = doublePairSet (p, minimumBy (compare `on` dist p) $ map fst subpth)
where
linkClosest (p, _) = doublePairSet (p, minimumBy (compare `on` dist p) $ map fst subpth)
linksAndPath' :: [RoomLink] -> [(Point2,Point2)] -> S.Set (Point2,Point2)
linksAndPath' :: [RoomLink] -> [(Point2, Point2)] -> S.Set (Point2, Point2)
linksAndPath' = linksAndPath . map lnkPosDir
testCrossWalls
:: [(Point2,Point2)]
-> (Point2,Point2)
-> Bool
testCrossWalls wls (a,b) = not $ any (isJust . uncurry (intersectSegSeg a b)) wls
testCrossWalls ::
[(Point2, Point2)] ->
(Point2, Point2) ->
Bool
testCrossWalls wls (a, b) = not $ any (isJust . uncurry (intersectSegSeg a b)) wls
--extra test whether both members of the path edge are in some poly
pairInPolys
:: [[Point2]]
-> (Point2,Point2)
-> Bool
pairInPolys polys (a,b) = any (pointInPolygon a) polys && any (pointInPolygon b) polys
pairInPolys ::
[[Point2]] ->
(Point2, Point2) ->
Bool
pairInPolys polys (a, b) = any (pointInPolygon a) polys && any (pointInPolygon b) polys
src/Dodge/Room/Pillar.hs
+78 -57
View File
@@ -1,43 +1,41 @@
module Dodge.Room.Pillar where
import Dodge.Default.Block
import Dodge.Placement.Instance.LightSource
import Dodge.Data
import qualified Data.Set as S
import Dodge.Cleat
import Dodge.PlacementSpot
import Dodge.Room.Modify.Girder
import Dodge.Data.GenWorld
import Dodge.Default.Block
import Dodge.LevelGen.Data
import Dodge.Placement.Instance
--import Dodge.LevelGen.Data
import Dodge.Room.Procedural
import Dodge.PlacementSpot
import Dodge.Room.Link
import Dodge.Room.Modify.Girder
import Dodge.Room.Procedural
import Geometry
import LensHelp
import RandomHelp
--import Control.Monad.State
--import System.Random
import qualified Data.Set as S
blockPillar :: Float -> Float -> Placement
blockPillar w' h' = ps0jPushPS (aline tl tr)
$ ps0jPushPS (aline tr br)
$ ps0jPushPS (aline br bl)
$ sps0 (aline bl tl)
blockPillar w' h' =
ps0jPushPS (aline tl tr) $
ps0jPushPS (aline tr br) $
ps0jPushPS (aline br bl) $
sps0 (aline bl tl)
where
w = w' - 10
h = h' - 10
tl = V2 (-w) h
tl = V2 (- w) h
tr = V2 w h
br = V2 w (-h)
bl = V2 (-w) (-h)
br = V2 w (- h)
bl = V2 (- w) (- h)
aline = PutLineBlock baseBlockPane 9
smallPillar :: PSType
smallPillar = PutBlock defaultBlock baseBlockPane $ reverse $ square 5
crossPillar :: Float -> Float -> Placement
crossPillar w' h' = ps0jPushPS (aline (V2 (-w) 0) (V2 w 0))
$ sps0 (aline (V2 0 (-h)) (V2 0 h))
crossPillar w' h' =
ps0jPushPS (aline (V2 (- w) 0) (V2 w 0)) $
sps0 (aline (V2 0 (- h)) (V2 0 h))
where
w = w' - 9
h = h' - 9
@@ -48,25 +46,39 @@ roomPillarsSquare = do
let rm' = roomRectAutoLinks 300 300
nlew = _numLinkEW (_rmType rm')
nlns = _numLinkNS (_rmType rm')
addlights <- takeOne
[ return . set rmPmnts [mntLS vShape
(rotateVAround (V2 150 150) a (V2 30 30))
(onXY (rotateVAround (V2 150 150) a) $ V3 60 60 95)
| a <- [0,pi/2,pi,3*pi/2] ]
, return . set rmPmnts [mntLS vShape
(rotateVAround (V2 150 150) a (V2 150 0))
(onXY (rotateVAround (V2 150 150) a) $ V3 150 20 95)
| a <- [0,pi/2,pi,3*pi/2] ]
, addGirderLights . set rmPmnts []
, return . (rmPmnts .++~
[ spanColLightBlackI 0.75 95 (V2 0 130) (V2 300 130)
, spanColLightBlackI 0.75 95 (V2 0 170) (V2 300 170)
,mntLightLnkCond $ resetPLUse $ rprBool $ \rp _ -> isOutLnk rp
] )
]
addlights <-
takeOne
[ return
. set
rmPmnts
[ mntLS
vShape
(rotateVAround (V2 150 150) a (V2 30 30))
(onXY (rotateVAround (V2 150 150) a) $ V3 60 60 95)
| a <- [0, pi / 2, pi, 3 * pi / 2]
]
, return
. set
rmPmnts
[ mntLS
vShape
(rotateVAround (V2 150 150) a (V2 150 0))
(onXY (rotateVAround (V2 150 150) a) $ V3 150 20 95)
| a <- [0, pi / 2, pi, 3 * pi / 2]
]
, addGirderLights . set rmPmnts []
, return
. ( rmPmnts
.++~ [ spanColLightBlackI 0.75 95 (V2 0 130) (V2 300 130)
, spanColLightBlackI 0.75 95 (V2 0 170) (V2 300 170)
, mntLightLnkCond $ resetPLUse $ rprBool $ \rp _ -> isOutLnk rp
]
)
]
rm <- addlights rm'
shuffleLinks $ rm & rmPmnts .++~ concatMap (replicate nlew . makepill) [South,North]
++ concatMap (replicate nlns . makepill) [East,West]
shuffleLinks $
rm & rmPmnts .++~ concatMap (replicate nlew . makepill) [South, North]
++ concatMap (replicate nlns . makepill) [East, West]
where
makepill edge = sps (rprBool $ \rp _ -> t edge rp) smallPillar
t edge rp = any (f edge) (_rpType rp) && _rpPlacementUse rp == 0
@@ -75,27 +87,36 @@ roomPillarsSquare = do
roomPillarsPassage :: RandomGen g => State g Room
roomPillarsPassage = do
let rm = roomRect 100 300 1 3
shuffleLinks $ rm & rmPmnts .~
[mntLS iShape (V2 50 0) (V3 50 10 90)
,mntLS iShape (V2 50 300) (V3 50 290 90)
,mntLS iShape (V2 0 150) (V3 10 150 90)
,mntLS iShape (V2 100 150) (V3 90 150 90)
] ++
[ sPS (V2 30 y) 0 smallPillar | y <- [50,90.. 250] ] ++
[ sPS (V2 70 y) 0 smallPillar | y <- [50,90.. 250] ]
shuffleLinks $
rm & rmPmnts
.~ [ mntLS iShape (V2 50 0) (V3 50 10 90)
, mntLS iShape (V2 50 300) (V3 50 290 90)
, mntLS iShape (V2 0 150) (V3 10 150 90)
, mntLS iShape (V2 100 150) (V3 90 150 90)
]
++ [sPS (V2 30 y) 0 smallPillar | y <- [50, 90 .. 250]]
++ [sPS (V2 70 y) 0 smallPillar | y <- [50, 90 .. 250]]
roomPillars :: RandomGen g => Float -> Float -> Float -> Int -> Int -> State g Room
roomPillars pillarsize w h wn hn = do
let rm = roomRect w h wn hn
npillars = length $ filter rpIsOffPath $ _rmPos rm
let plmnts = replicate npillars (blockPillar (0.5*pilw) (0.5*pilh) & plSpot .~ rprBool
(\rp _ -> rpIsOffPath rp
&& _rpPlacementUse rp == 0
&& _rpLinkStatus rp == NotLink )
let plmnts =
replicate
npillars
( blockPillar (0.5 * pilw) (0.5 * pilh) & plSpot
.~ rprBool
( \rp _ ->
rpIsOffPath rp
&& _rpPlacementUse rp == 0
&& _rpLinkStatus rp == NotLink
)
)
addGirderLights $ rm
& cleatSide
& rmPmnts .~ plmnts
& rmName .~ "rectPillars"
where
pilw = (( w - 40 * (fromIntegral wn +1) ) / fromIntegral wn) - pillarsize
pilh = (( h - 40 * (fromIntegral hn +1) ) / fromIntegral hn) - pillarsize
addGirderLights $
rm
& cleatSide
& rmPmnts .~ plmnts
& rmName .~ "rectPillars"
where
pilw = ((w - 40 * (fromIntegral wn + 1)) / fromIntegral wn) - pillarsize
pilh = ((h - 40 * (fromIntegral hn + 1)) / fromIntegral hn) - pillarsize
src/Dodge/Room/Procedural.hs
+278 -221
View File
@@ -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
src/Dodge/Room/RezBox.hs
+87 -84
View File
@@ -1,128 +1,131 @@
module Dodge.Room.RezBox where
import Dodge.LevelGen.Data
import Dodge.Cleat
--import Dodge.PlacementSpot
--import Dodge.Room.RunPast
import Dodge.RoomLink
import Dodge.LightSource
--import Dodge.Room.LasTurret
import Dodge.Data
--import Dodge.Default
--import Dodge.RoomLink
import Dodge.Tree
import RandomHelp
import Dodge.Room.Door
import Dodge.Room.Corridor
--import Dodge.Room.Room
import Dodge.Room.Link
import Dodge.Room.Procedural
--import Dodge.Room.Foreground
import Dodge.Room.RoadBlock
import Dodge.Placement.Instance
import Dodge.Item.Random
--import Dodge.Item.Weapon.BulletGuns
--import Dodge.Item.Weapon.Utility
--import Dodge.LevelGen.Data
--import Geometry.Data
import Geometry
import Padding
import LensHelp
--import Color
--import Shape
import qualified Data.Set as S
--import Data.Maybe
import Dodge.Cleat
import Dodge.Data.GenWorld
import Dodge.Item.Random
import Dodge.LevelGen.Data
import Dodge.LightSource
import Dodge.Placement.Instance
import Dodge.Room.Corridor
import Dodge.Room.Door
import Dodge.Room.Link
import Dodge.Room.Procedural
import Dodge.Room.RoadBlock
import Dodge.RoomLink
import Dodge.Tree
import Geometry
import LensHelp
import Padding
import RandomHelp
rezBox :: LightSource -> Room
rezBox ls = roomRect 40 60 1 1
& rmPmnts .~ [ sPS (V2 20 1) 0 $ PutLS ls]
& restrictInLinks (\(V2 _ h,_)-> h < 1)
& restrictOutLinks (\(V2 _ h,_)-> h > 59)
& rmName .~ "rezBox"
rezBox ls =
roomRect 40 60 1 1
& rmPmnts .~ [sPS (V2 20 1) 0 $ PutLS ls]
& restrictInLinks (\(V2 _ h, _) -> h < 1)
& restrictOutLinks (\(V2 _ h, _) -> h > 59)
& rmName .~ "rezBox"
rezBox' :: RandomGen g => State g (MetaTree Room String)
rezBox' = do
col <- rezColor
return $ tToBTree "rezBox'" $ treePost
[roomRect 40 60 1 1
& rmPmnts .~ [ sPS (V2 20 1) 0 $ PutLS col]
& restrictInLinks (\(V2 _ h,_)-> h < 1)
& restrictOutLinks (\(V2 _ h,_)-> h > 59)
& rmName .~ "rezBox"
, cleatOnward door
]
return $
tToBTree "rezBox'" $
treePost
[ roomRect 40 60 1 1
& rmPmnts .~ [sPS (V2 20 1) 0 $ PutLS col]
& restrictInLinks (\(V2 _ h, _) -> h < 1)
& restrictOutLinks (\(V2 _ h, _) -> h > 59)
& rmName .~ "rezBox"
, cleatOnward door
]
rezBoxesWp :: RandomGen g => State g (Tree Room)
rezBoxesWp = do
w <- state $ randomR (100,400)
h <- state $ randomR (40,40)
w <- state $ randomR (100, 400)
h <- state $ randomR (40, 40)
theweapon <- randBlockBreakWeapon
thecol <- rezColor
let aroom = rezInvBox thecol -- & rmConnectsTo .~ S.singleton (OnEdge North)
let isnorth = S.member (OnEdge North) . _rlType
centralRoom <- shuffleLinks $(roomRectAutoLinks w h) {_rmPmnts = []}
& rmLinks %~ setLinkType InLink isnorth
centralRoom <-
shuffleLinks $(roomRectAutoLinks w h){_rmPmnts = []}
& rmLinks %~ setLinkType InLink isnorth
onwardpassage <- shootOutPassage
let n = length $ getLinksOfType (OnEdge North) $ _rmLinks centralRoom
let rezrooms = map adddoor
$ wpAdd theweapon aroom : replicate (n-2) aroom
return $ treeFromTrunk [ rezBox thecol , door ]
$ Node centralRoom (rezrooms ++ [onwardpassage])
let n = length $ getLinksOfType (OnEdge North) $ _rmLinks centralRoom
let rezrooms =
map adddoor $
wpAdd theweapon aroom : replicate (n -2) aroom
return $
treeFromTrunk [rezBox thecol, door] $
Node centralRoom (rezrooms ++ [onwardpassage])
where
adddoor rm = treeFromPost [ connectsToNorth door ] rm
adddoor rm = treeFromPost [connectsToNorth door] rm
connectsToNorth = rmConnectsTo .~ S.member (OnEdge North)
maybeBlockedPassage :: RandomGen g => State g (Tree Room)
maybeBlockedPassage = fmap (pure . cleatOnward)
$ join $ takeOne [return corridor, blockedCorridorCloseBlocks]
maybeBlockedPassage =
fmap (pure . cleatOnward) $
join $ takeOne [return corridor, blockedCorridorCloseBlocks]
shootOutPassage :: RandomGen g => State g (Tree Room)
shootOutPassage = fmap (pure . cleatOnward)
$ join $ takeOne [ blockedCorridorCloseBlocks]
shootOutPassage =
fmap (pure . cleatOnward) $
join $ takeOne [blockedCorridorCloseBlocks]
rezBoxesWpCrit :: RandomGen g => State g (Tree Room)
rezBoxesWpCrit = do
w <- state $ randomR (200,400)
h <- state $ randomR (40,40)
w <- state $ randomR (200, 400)
h <- state $ randomR (40, 40)
thecol <- rezColor
theweapon <- randBlockBreakWeapon
let bottomEdgeTest (V2 _ y,_) = y < 1
let bottomEdgeTest (V2 _ y, _) = y < 1
aroom = rezInvBox thecol
let centralRoom = (roomRectAutoLinks w h) {_rmPmnts = []}
let centralRoom = (roomRectAutoLinks w h){_rmPmnts = []}
onwardpassage <-
over root (rmConnectsTo .~ S.member (OnEdge West)) <$> maybeBlockedPassage
let n = length $ filter bottomEdgeTest $ map lnkPosDir $ _rmLinks centralRoom
i <- state $ randomR (0,n-3)
j <- state $ randomR (i,n-2)
let rezrooms = map adddoor
$ insertAt i (wpAdd theweapon aroom)
$ insertAt j (crAdd aroom)
$ replicate (n-3) aroom
return $ treeFromTrunk [rezBox thecol , door]
$ Node centralRoom (rezrooms ++ [onwardpassage])
i <- state $ randomR (0, n -3)
j <- state $ randomR (i, n -2)
let rezrooms =
map adddoor $
insertAt i (wpAdd theweapon aroom) $
insertAt j (crAdd aroom) $
replicate (n -3) aroom
return $
treeFromTrunk [rezBox thecol, door] $
Node centralRoom (rezrooms ++ [onwardpassage])
where
adddoor rm = treeFromPost [ door & rmConnectsTo .~ S.member (OnEdge North)] rm
adddoor rm = treeFromPost [door & rmConnectsTo .~ S.member (OnEdge North)] rm
crAdd :: Room -> Room
crAdd = rmPmnts .:~ sPS (V2 20 10) (0.5*pi) randC1
crAdd = rmPmnts .:~ sPS (V2 20 10) (0.5 * pi) randC1
rezBoxes :: RandomGen g => State g (MetaTree Room String)
rezBoxes = do
w <- state $ randomR (100,400)
h <- state $ randomR (40,40)
w <- state $ randomR (100, 400)
h <- state $ randomR (40, 40)
thecol <- rezColor
let bottomEdgeTest = S.member (OnEdge South) . _rlType
dbox = treeFromPost [ door & rmConnectsTo .~ S.member (OnEdge South)]
(rezInvBox thecol)
centralRoom <- shuffleLinks $ (roomRectAutoLinks w h) {_rmPmnts = []}
& rmLinks %~ setInLinks bottomEdgeTest
let bottomEdgeTest = S.member (OnEdge South) . _rlType
dbox =
treeFromPost
[door & rmConnectsTo .~ S.member (OnEdge South)]
(rezInvBox thecol)
centralRoom <-
shuffleLinks $
(roomRectAutoLinks w h){_rmPmnts = []}
& rmLinks %~ setInLinks bottomEdgeTest
let n = length $ filter bottomEdgeTest $_rmLinks centralRoom
return $ tToBTree "rezBoxes" $treeFromTrunk [rezBox thecol, door]
$ Node centralRoom (replicate (n-1) dbox ++ [Node (cleatOnward door) []])
return $
tToBTree "rezBoxes" $treeFromTrunk [rezBox thecol, door] $
Node centralRoom (replicate (n -1) dbox ++ [Node (cleatOnward door) []])
rezColor :: RandomGen g => State g LightSource
rezColor = do
col <- takeOne [V3 0.0 0.1 0.5, V3 0.0 0.5 0.1]
h <- takeOne [30,50,80,90,90,90,90]
rad <- takeOne [150,200,200,250,250,300,300,300]
h <- takeOne [30, 50, 80, 90, 90, 90, 90]
rad <- takeOne [150, 200, 200, 250, 250, 300, 300, 300]
return $ lsPosColRad (V3 0 0 h) col rad
rezInvBox :: LightSource -> Room
@@ -131,6 +134,6 @@ rezInvBox = swapInOutLinks . rezBox
wpAdd :: Item -> Room -> Room
wpAdd wp = rmPmnts %~ f
where
f (x:xs) = sPS (V2 15 30) 1 (PutFlIt wp) : g x : xs
f (x : xs) = sPS (V2 15 30) 1 (PutFlIt wp) : g x : xs
f _ = [sPS (V2 15 30) 1 (PutFlIt wp)]
g x = x & plIDCont .~ const flickerMod
src/Dodge/Room/RoadBlock.hs
+64 -58
View File
@@ -1,23 +1,21 @@
{- Connecting rooms designed with a pass-through technique in mind. -}
module Dodge.Room.RoadBlock where
import Dodge.Default.Wall
import Dodge.Default.Block
import Dodge.Cleat
import Dodge.Data
import Dodge.RoomLink
import Geometry
import Dodge.Default.Room
import Dodge.LevelGen.Data
import Dodge.Room.Link
import Dodge.Placement.Instance
import Dodge.Room.Corridor
--import Dodge.LevelGen.Data
--import Dodge.Default.Wall
import RandomHelp
import Dodge.Creature
import Dodge.Tree
import Control.Lens
import Dodge.Cleat
import Dodge.Creature
import Dodge.Data.GenWorld
import Dodge.Default.Block
import Dodge.Default.Room
import Dodge.Default.Wall
import Dodge.LevelGen.Data
import Dodge.Placement.Instance
import Dodge.Room.Corridor
import Dodge.Room.Link
import Dodge.RoomLink
import Dodge.Tree
import Geometry
import RandomHelp
armouredCorridor :: RandomGen g => State g Room
armouredCorridor = fmap (replacePutID 0 [PutCrit $ addArmour autoCrit]) litCorridor90
@@ -27,41 +25,47 @@ A corridor of random length with a 90 degree link at the end.
-}
litCorridor90 :: RandomGen g => State g Room
litCorridor90 = do
h <- state $ randomR (500,800)
h <- state $ randomR (500, 800)
let poly = rectNSWE h 0 0 40
poly2 = rectNSWE (h-60) (h-100) (-60) 5
pure $ defaultRoom
{ _rmPolys = [poly,poly2]
, _rmLinks =
[ outLink (V2 40 (h - 80)) (-pi/2)
, inLink (V2 20 0 ) pi ]
, _rmPath = foldMap doublePairSet
[( V2 20 0 , V2 20 (h-40) )
,( V2 0 (h-40) , V2 20 (h-40) )
,( V2 40 (h-40) , V2 20 (h-40) )
]
, _rmPmnts =
[ sPS (V2 20 (h-5)) 0 putLamp
, spanLightI (V2 0 (0.4*h)) (V2 40 (0.4*h))
, windowLine (V2 0 (h-20)) (V2 40 (h-20))
, sPS (V2 (-50) (h-85)) 0 putLamp
, windowLine (V2 (-40) (h-60)) (V2 (-40) (h-100))
, sPS (V2 20 (h-40)) 0 $ PutID 0
, sPS (V2 (-20) (h-80)) 0 $ PutID 2
]
, _rmBound = [poly]
}
poly2 = rectNSWE (h -60) (h -100) (-60) 5
pure $
defaultRoom
{ _rmPolys = [poly, poly2]
, _rmLinks =
[ outLink (V2 40 (h - 80)) (- pi / 2)
, inLink (V2 20 0) pi
]
, _rmPath =
foldMap
doublePairSet
[ (V2 20 0, V2 20 (h -40))
, (V2 0 (h -40), V2 20 (h -40))
, (V2 40 (h -40), V2 20 (h -40))
]
, _rmPmnts =
[ sPS (V2 20 (h -5)) 0 putLamp
, spanLightI (V2 0 (0.4 * h)) (V2 40 (0.4 * h))
, windowLine (V2 0 (h -20)) (V2 40 (h -20))
, sPS (V2 (-50) (h -85)) 0 putLamp
, windowLine (V2 (-40) (h -60)) (V2 (-40) (h -100))
, sPS (V2 20 (h -40)) 0 $ PutID 0
, sPS (V2 (-20) (h -80)) 0 $ PutID 2
]
, _rmBound = [poly]
}
-- | A random length corridor with a destructible block blocking it.
longBlockedCorridor :: RandomGen g => Int -> State g (Tree Room)
longBlockedCorridor maxn = do
r <- state $ randomR (0,pi)
n <- state $ randomR (0,maxn)
let plmnts = [sPS (V2 20 40) r $ dirtPoly $ square 10
,sPS (V2 20 15) 0 putLamp
r <- state $ randomR (0, pi)
n <- state $ randomR (0, maxn)
let plmnts =
[ sPS (V2 20 40) r $ dirtPoly $ square 10
, sPS (V2 20 15) 0 putLamp
]
sequence $ treeFromPost (replicate n $ shuffleLinks corridor)
$ return $ cleatOnward $ set rmPmnts plmnts corridor
sequence $
treeFromPost (replicate n $ shuffleLinks corridor) $
return $ cleatOnward $ set rmPmnts plmnts corridor
-- | A single corridor with a destructible block blocking it.
blockedCorridor :: RandomGen g => State g (Tree Room)
@@ -73,18 +77,20 @@ dirtPoly = PutBlock defaultDirtBlock defaultDirtWall . reverse
-- | A single corridor with a destructible block blocking it.
blockedCorridorCloseBlocks :: RandomGen g => State g Room
blockedCorridorCloseBlocks = do
r <- state $ randomR (0,pi)
r' <- state $ randomR (0,pi)
theblocks <- takeOne
[ [sPS (V2 20 40) r $ dirtPoly $ square 8]
--, [ sPS (V2 5 40) r $ dirtPoly $ square 10
-- , sPS (V2 35 40) (r+0.5) $ dirtPoly $ square 10
-- ]
--,
--[ sPS (V2 5 50) r $ dirtPoly $ square 10
--, sPS (V2 35 35) (r+0.5) $ dirtPoly $ square 10
, [ sPS (V2 6 25) r $ dirtPoly $ square 8
, sPS (V2 35 20) r' $ dirtPoly $ square 8
r <- state $ randomR (0, pi)
r' <- state $ randomR (0, pi)
theblocks <-
takeOne
[ [sPS (V2 20 40) r $ dirtPoly $ square 8]
, --, [ sPS (V2 5 40) r $ dirtPoly $ square 10
-- , sPS (V2 35 40) (r+0.5) $ dirtPoly $ square 10
-- ]
--,
--[ sPS (V2 5 50) r $ dirtPoly $ square 10
--, sPS (V2 35 35) (r+0.5) $ dirtPoly $ square 10
[ sPS (V2 6 25) r $ dirtPoly $ square 8
, sPS (V2 35 20) r' $ dirtPoly $ square 8
]
]
]
return $ corridor & rmPmnts .~ theblocks
src/Dodge/Room/Room.hs
+283 -232
View File
@@ -1,111 +1,114 @@
--{-# LANGUAGE TupleSections #-}
module Dodge.Room.Room
( shootingRange
, weaponRoom
, roomMiniIntro
, roomCCrits
, doubleCorridorBarrels
, pistolerRoom
, spawnerRoom
, corDoor
) where
import Dodge.Cleat
import Dodge.Item.Display
import Dodge.Data
import Dodge.PlacementSpot
import Dodge.RoomLink
import Dodge.Default.Room
import Dodge.Creature
import Dodge.Room.Pillar
import Dodge.Room.Foreground
import Dodge.Room.Girder
import Dodge.Room.Modify.Girder
import Dodge.LevelGen.Data
import RandomHelp
import Dodge.Tree
import Dodge.Placement.Instance
import Dodge.Placement.Random
--import Dodge.LevelGen.Data
import Dodge.Room.Procedural
import Dodge.Room.Corridor
--import Dodge.Room.Tanks
import Dodge.Room.Link
import Dodge.Room.Door
import Dodge.Room.Airlock
import Geometry
import MonadHelp
import LensHelp
module Dodge.Room.Room (
shootingRange,
weaponRoom,
roomMiniIntro,
roomCCrits,
doubleCorridorBarrels,
pistolerRoom,
spawnerRoom,
corDoor,
) where
import qualified Data.Set as S
import Dodge.Cleat
import Dodge.Creature
import Dodge.Data.GenWorld
import Dodge.Default.Room
import Dodge.Item.Display
import Dodge.LevelGen.Data
import Dodge.Placement.Instance
import Dodge.Placement.Random
import Dodge.PlacementSpot
import Dodge.Room.Airlock
import Dodge.Room.Corridor
import Dodge.Room.Door
import Dodge.Room.Foreground
import Dodge.Room.Girder
import Dodge.Room.Link
import Dodge.Room.Modify.Girder
import Dodge.Room.Pillar
import Dodge.Room.Procedural
import Dodge.RoomLink
import Dodge.Tree
import Geometry
import LensHelp
import MonadHelp
import RandomHelp
roomC :: RandomGen g => Float -> Float -> State g Room
roomC w h = do
wallf <- takeOne [ crystalLine , windowLine ]
wallf <- takeOne [crystalLine, windowLine]
maybeaddgird <- takeOne [return, addRandomGirderFrom West 0, addRandomGirderFrom North 0]
maybeaddgird =<< shuffleLinks (roomRectAutoLinks w h
& rmLinks %~
( setInLinks (\rl -> S.fromList [FromEdge East 0,OnEdge South] `S.isSubsetOf` _rlType rl)
. setOutLinks (\rl -> OnEdge West `S.member` _rlType rl)
maybeaddgird
=<< shuffleLinks
( roomRectAutoLinks w h
& rmLinks
%~ ( setInLinks (\rl -> S.fromList [FromEdge East 0, OnEdge South] `S.isSubsetOf` _rlType rl)
. setOutLinks (\rl -> OnEdge West `S.member` _rlType rl)
)
& rmPmnts .:~ wallf (V2 (w / 2) 0) (V2 (w / 2) (h -60))
& rmPmnts .:~ sps0 (PutDecoration (highMesh (V2 0 0) (V2 0 h) 50))
& rmRandPSs .~ [farside]
)
& rmPmnts .:~ wallf (V2 (w/2) 0) (V2 (w/2) (h-60))
& rmPmnts .:~ sps0 (PutDecoration (highMesh (V2 0 0) (V2 0 h) 50))
& rmRandPSs .~ [farside]
)
where
farside = do
x <- state $ randomR (5, w/2 - 20)
x <- state $ randomR (5, w / 2 - 20)
y <- state $ randomR (5, h - 70)
a <- state $ randomR (0, 2*pi)
return (V2 x y,a)
a <- state $ randomR (0, 2 * pi)
return (V2 x y, a)
roomPadCut :: [Point2] -> Point2 -> Room
roomPadCut ps p = defaultRoom
{ _rmPolys = [ps]
, _rmLinks = muout [(p,0)] ++ muin [(V2 0 0,pi)]
, _rmPath = doublePairSet (V2 0 0,p)
}
roomPadCut ps p =
defaultRoom
{ _rmPolys = [ps]
, _rmLinks = muout [(p, 0)] ++ muin [(V2 0 0, pi)]
, _rmPath = doublePairSet (V2 0 0, p)
}
branchWith :: Room -> [Tree Room] -> Tree Room
branchWith r = Node r . (return (cleatOnward door) :)
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
awindow h xl xr = windowLine (V2 xl h) (V2 xr h)
plmnts =
[awindow hf (wth-60) wllen
,awindow (2*hf) (wth-wllen) 60
,awindow (3*hf) (wth-60) wllen
,awindow (4*hf) (wth-wllen) 60
,blockLine (V2 0 (1*hf)) (V2 wllen (1*hf))
,blockLine (V2 (wth-wllen) (2*hf)) (V2 wth (2*hf))
,blockLine (V2 0 (3*hf)) (V2 wllen (3*hf))
,blockLine (V2 (wth-wllen) (4*hf)) (V2 wth (4*hf))
, sPS (V2 (wth/2) (hgt/2)) 0 putLamp
wth <- state $ randomR (200, 400)
hgt <- state $ randomR (400, 600)
wllen <- state $ randomR (60, wth / 2 -40)
let hf = hgt / 5
awindow h xl xr = windowLine (V2 xl h) (V2 xr h)
plmnts =
[ awindow hf (wth -60) wllen
, awindow (2 * hf) (wth - wllen) 60
, awindow (3 * hf) (wth -60) wllen
, awindow (4 * hf) (wth - wllen) 60
, blockLine (V2 0 (1 * hf)) (V2 wllen (1 * hf))
, blockLine (V2 (wth - wllen) (2 * hf)) (V2 wth (2 * hf))
, blockLine (V2 0 (3 * hf)) (V2 wllen (3 * hf))
, blockLine (V2 (wth - wllen) (4 * hf)) (V2 wth (4 * hf))
, sPS (V2 (wth / 2) (hgt / 2)) 0 putLamp
]
let northPSs = do
cry <- randomRanges [3*hf+10,4*hf-10 ,4*hf+10,5*hf-10 ]
crx <- state $ randomR (wllen,wth-(wllen+40))
return (V2 crx cry,1.5*pi)
midPS = return (V2 (wth-20) (hgt/2+40), pi)
return $ roomRect wth hgt 2 4
& rmPmnts .~ plmnts
& rmRandPSs .~ [northPSs,midPS]
& rmName .~ "glassSwitchBack"
cry <- randomRanges [3 * hf + 10, 4 * hf -10, 4 * hf + 10, 5 * hf -10]
crx <- state $ randomR (wllen, wth - (wllen + 40))
return (V2 crx cry, 1.5 * pi)
midPS = return (V2 (wth -20) (hgt / 2 + 40), pi)
return $
roomRect wth hgt 2 4
& rmPmnts .~ plmnts
& rmRandPSs .~ [northPSs, midPS]
& rmName .~ "glassSwitchBack"
glassSwitchBackCrits :: RandomGen g => State g Room
glassSwitchBackCrits = glassSwitchBack <&> rmPmnts .++~
[ spNoID (PSRoomRand 0 (uncurry PS)) (PutCrit miniGunCrit)
, spNoID (PSRoomRand 1 (uncurry PS)) randC1
]
glassSwitchBackCrits =
glassSwitchBack <&> rmPmnts
.++~ [ spNoID (PSRoomRand 0 (uncurry PS)) (PutCrit miniGunCrit)
, spNoID (PSRoomRand 1 (uncurry PS)) randC1
]
miniTree2 :: RandomGen g => State g (Tree Room)
miniTree2 = do
rm <- glassSwitchBackCrits >>= shuffleLinks . restrictInLinks (\p -> (sndV2 . fst) p < 70)
return $ branchWith rm (replicate 3 $ treePost [door,corridor,critInDeadEnd])
return $ branchWith rm (replicate 3 $ treePost [door, corridor, critInDeadEnd])
-- So, the idea is to attach outer children to the bottommost right nodes
-- inside an inner tree
@@ -117,217 +120,265 @@ roomMiniIntro = do
roomCenterPillar :: RandomGen g => State g Room
roomCenterPillar = do
addHighGirder' =<< (shuffleLinks . restrictInLinks ((\p -> dist p (V2 120 0) < 10) . fst)
$ cleatSide
$ set rmPmnts plmnts
$ set rmName "roomCenterPillar"
$ roomRect 240 240 2 2
)
where
plmnts =
addHighGirder'
=<< ( shuffleLinks . restrictInLinks ((\p -> dist p (V2 120 0) < 10) . fst) $
cleatSide $
set rmPmnts plmnts $
set rmName "roomCenterPillar" $
roomRect 240 240 2 2
)
where
plmnts =
[ blockLine (V2 115 115) (V2 115 125)
, blockLine (V2 125 115) (V2 125 125)
-- , mntLightLnkCond useUnusedLnk
, mntLightLnkCond (resetPLUse $ rprBool $ \rp _ -> isInLnk rp)
, mntLightLnkCond (resetPLUse $ rprBool $ \rp _ -> isOutLnk rp)
, -- , mntLightLnkCond useUnusedLnk
mntLightLnkCond (resetPLUse $ rprBool $ \rp _ -> isInLnk rp)
, mntLightLnkCond (resetPLUse $ rprBool $ \rp _ -> isOutLnk rp)
]
weaponEmptyRoom :: State StdGen (Tree Room)
weaponEmptyRoom = do
w <- state $ randomR (220,300)
h <- state $ randomR (220,300)
w <- state $ randomR (220, 300)
h <- state $ randomR (220, 300)
wp <- randFirstWeapon
let plmnts =
[sPS (V2 (w/2) (h-40)) 0 $ PutFlIt wp
,sPS (V2 20 20) (pi/2) randC1
,sPS (V2 (w-20) 20) (pi/2) randC1
,mntLightLnkCond useUnusedLnk
let plmnts =
[ sPS (V2 (w / 2) (h -40)) 0 $ PutFlIt wp
, sPS (V2 20 20) (pi / 2) randC1
, sPS (V2 (w -20) 20) (pi / 2) randC1
, mntLightLnkCond useUnusedLnk
]
f (V2 x y,a) = (a == pi && x > 25 && x < w - 25) || (a /= 0 && y > w - 30)
rm <- addHighGirder >=> shuffleLinks
$ restrictRMInLinksPD f (roomRect w h 2 2 & rmPmnts .~ plmnts)
return $ treePost [ corridor, cleatSide $ cleatOnward rm ]
f (V2 x y, a) = (a == pi && x > 25 && x < w - 25) || (a /= 0 && y > w - 30)
rm <-
addHighGirder >=> shuffleLinks $
restrictRMInLinksPD f (roomRect w h 2 2 & rmPmnts .~ plmnts)
return $ treePost [corridor, cleatSide $ cleatOnward rm]
weaponUnderCrits :: RandomGen g => Int -> State g (MetaTree Room String)
weaponUnderCrits i = do
let addwpat p = rmPmnts .:~ PickOnePlacement i (sPS p 0 $ RandPS $ fmap PutFlIt randFirstWeapon)
continuationRoom = treePost
[ addwpat (V2 20 0) corridorN
, addwpat (V2 20 0) corridorN
, cleatOnward $ corridorN & rmPmnts .~
[ sPS (V2 20 0) (negate $ pi/2) randC1
, sPS (V2 20 20) ( pi/2) randC1
continuationRoom =
treePost
[ addwpat (V2 20 0) corridorN
, addwpat (V2 20 0) corridorN
, cleatOnward $
corridorN & rmPmnts
.~ [ sPS (V2 20 0) (negate $ pi / 2) randC1
, sPS (V2 20 20) (pi / 2) randC1
]
]
]
rcp <- roomCenterPillar
rmpils <- roomPillars 30 240 240 2 2
deadEndRoom' <- takeOne [ addwpat (V2 120 20) rmpils , addwpat (V2 120 20) $ cleatSide rcp]
junctionRoom <- takeOne [ tEast, tWest]
rToOnward "weaponUnderCrits" $ treeFromTrunk [ corridorN , corridorN]
$ Node junctionRoom [continuationRoom ,pure deadEndRoom' ]
deadEndRoom' <- takeOne [addwpat (V2 120 20) rmpils, addwpat (V2 120 20) $ cleatSide rcp]
junctionRoom <- takeOne [tEast, tWest]
rToOnward "weaponUnderCrits" $
treeFromTrunk [corridorN, corridorN] $
Node junctionRoom [continuationRoom, pure deadEndRoom']
weaponBehindPillar :: RandomGen g => State g (Tree Room)
weaponBehindPillar = do
wpa <- state $ randomR (0,pi)
wpos <- takeOne [V2 120 160,V2 80 40,V2 160 40,V2 220 200,V2 40 200,V2 120 35]
cpos <- takeOne $ [V2 x y | x <- [20,220], y <- [20,40]] ++ [V2 120 160,V2 120 200]
weaponBehindPillar = do
wpa <- state $ randomR (0, pi)
wpos <- takeOne [V2 120 160, V2 80 40, V2 160 40, V2 220 200, V2 40 200, V2 120 35]
cpos <- takeOne $ [V2 x y | x <- [20, 220], y <- [20, 40]] ++ [V2 120 160, V2 120 200]
rcp <- roomCenterPillar
return $ treePost
[ corridor
, rcp & rmPmnts ++.~
[sPS wpos wpa $ RandPS $ fmap PutFlIt randFirstWeapon
,sPS cpos (argV $ V2 120 80 -.- cpos) randC1
return $
treePost
[ corridor
, rcp & rmPmnts
++.~ [ sPS wpos wpa $ RandPS $ fmap PutFlIt randFirstWeapon
, sPS cpos (argV $ V2 120 80 -.- cpos) randC1
]
, cleatOnward $ set rmPmnts [sPS (V2 20 60) (negate $ pi / 2) randC1] corridorN
]
, cleatOnward $ set rmPmnts [sPS (V2 20 60) (negate $ pi/2) randC1] corridorN
]
weaponBetweenPillars :: State StdGen (MetaTree Room String)
weaponBetweenPillars = do
(w,wn) <- takeOne [(240,2),(340,3)]
(h,hn) <- takeOne [(240,2),(340,3)]
let wpPos = rprBool $ \rp r -> and
[ rpIsOnPath rp
, _rpPlacementUse rp == 0
, _rpLinkStatus rp == NotLink
, any ((<100) . dist (_rpPos rp)) (usedRoomInLinkPoss r)
]
ncrits <- state $ randomR (1,3)
(w, wn) <- takeOne [(240, 2), (340, 3)]
(h, hn) <- takeOne [(240, 2), (340, 3)]
let wpPos = rprBool $ \rp r ->
and
[ rpIsOnPath rp
, _rpPlacementUse rp == 0
, _rpLinkStatus rp == NotLink
, any ((< 100) . dist (_rpPos rp)) (usedRoomInLinkPoss r)
]
ncrits <- state $ randomR (1, 3)
wp <- randFirstWeapon
critPlacementSpots <- replicateM ncrits $ randDirPS $ rprBool $ \rp r ->
rpIsOnPath rp
&& _rpPlacementUse rp == 0
&& all ((>100) . dist (_rpPos rp)) (usedRoomLinkPoss r)
(roomPillars 30 w h wn hn
<&> rmPmnts .++~ map (`sps` randC1) critPlacementSpots ++ [ sps wpPos (PutFlIt wp) ]
<&> cleatOnward) >>= rToOnward ("weaponBetweenPillars_"++itemString wp) . pure
critPlacementSpots <- replicateM ncrits $
randDirPS $
rprBool $ \rp r ->
rpIsOnPath rp
&& _rpPlacementUse rp == 0
&& all ((> 100) . dist (_rpPos rp)) (usedRoomLinkPoss r)
( roomPillars 30 w h wn hn
<&> rmPmnts .++~ map (`sps` randC1) critPlacementSpots ++ [sps wpPos (PutFlIt wp)]
<&> cleatOnward
)
>>= rToOnward ("weaponBetweenPillars_" ++ itemString wp) . pure
weaponLongCorridor :: RandomGen g => State g (Tree Room)
weaponLongCorridor = do
rt <- takeOne [tEast, tWest]
connectingRoom <- takeOne [tEast & rmPmnts .~ [spanLightI (V2 (-30) 40) (V2 (-30) 80)] ]
i1 <- state $ randomR (2,5)
i2 <- state $ randomR (2,5)
let branch1 = treeFromTrunk (replicate i1 corridorN)
(pure . cleatSide . cleatOnward $ putCrs connectingRoom)
let branch2 = treeFromTrunk (replicate i2 corridorN) (pure . cleatSide $ putWp corridor)
return $ Node rt [branch1,branch2]
where
putCrs = rmPmnts .++~ [sPS (V2 10 40) (-pi/2) randC1 ,sPS (V2 (-10) 40) (-pi/2) randC1 ]
putWp = rmPmnts .~ [sPS (V2 20 60) 0 $ RandPS $ fmap PutFlIt randFirstWeapon ,spanLightI (V2 0 40) (V2 40 40)]
connectingRoom <- takeOne [tEast & rmPmnts .~ [spanLightI (V2 (-30) 40) (V2 (-30) 80)]]
i1 <- state $ randomR (2, 5)
i2 <- state $ randomR (2, 5)
let branch1 =
treeFromTrunk
(replicate i1 corridorN)
(pure . cleatSide . cleatOnward $ putCrs connectingRoom)
let branch2 = treeFromTrunk (replicate i2 corridorN) (pure . cleatSide $ putWp corridor)
return $ Node rt [branch1, branch2]
where
putCrs = rmPmnts .++~ [sPS (V2 10 40) (- pi / 2) randC1, sPS (V2 (-10) 40) (- pi / 2) randC1]
putWp = rmPmnts .~ [sPS (V2 20 60) 0 $ RandPS $ fmap PutFlIt randFirstWeapon, spanLightI (V2 0 40) (V2 40 40)]
critInDeadEnd :: Room
critInDeadEnd = deadEndRoom & rmPmnts .~ [sPS (V2 0 0) 0 randC1]
deadEndRoom :: Room
deadEndRoom = defaultRoom
{ _rmPolys = [rectNSWE 40 (-20) (-20) 20 ]
, _rmLinks = muout (init lnks) ++ muin [last lnks]
, _rmPath = mempty
, _rmPmnts = [sPS (V2 0 (-10)) 0 putLamp]
, _rmBound = [rectNSWE 20 (-20) (-30) 30]
, _rmName = "deadEndRoom"
}
where
lnks = [(V2 0 30 ,0) ]
deadEndRoom =
defaultRoom
{ _rmPolys = [rectNSWE 40 (-20) (-20) 20]
, _rmLinks = muout (init lnks) ++ muin [last lnks]
, _rmPath = mempty
, _rmPmnts = [sPS (V2 0 (-10)) 0 putLamp]
, _rmBound = [rectNSWE 20 (-20) (-30) 30]
, _rmName = "deadEndRoom"
}
where
lnks = [(V2 0 30, 0)]
{- A random Either tree with a weapon and melee monster challenge. -}
weaponRoom :: Int -> State StdGen (MetaTree Room String)
weaponRoom i = join $ takeOne
[ weaponEmptyRoom >>= rToOnward "weaponEmptyRoom"
, weaponUnderCrits i -- this int is used for PickOnePlacement
, weaponBehindPillar >>= rToOnward "weaponBehindPillar"
, weaponBetweenPillars-- >>= rToOnward "weaponBetweenPillars"
, weaponLongCorridor >>= rToOnward "weaponLongCorridor"
]
weaponRoom i =
join $
takeOne
[ weaponEmptyRoom >>= rToOnward "weaponEmptyRoom"
, weaponUnderCrits i -- this int is used for PickOnePlacement
, weaponBehindPillar >>= rToOnward "weaponBehindPillar"
, weaponBetweenPillars -- >>= rToOnward "weaponBetweenPillars"
, weaponLongCorridor >>= rToOnward "weaponLongCorridor"
]
roomCCrits :: RandomGen g => Int -> State g Room
roomCCrits i = roomC 200 200
<&> rmPmnts .++~ replicate i (spNoID (PSRoomRand 0 (uncurry PS)) randC1)
roomCCrits i =
roomC 200 200
<&> rmPmnts .++~ replicate i (spNoID (PSRoomRand 0 (uncurry PS)) randC1)
doubleCorridorBarrels :: RandomGen g => State g Room
doubleCorridorBarrels = do
h <- state $ randomR (200,300)
h <- state $ randomR (200, 300)
let cond x = (sndV2 . fst) x < h - 40
return $ restrictInLinks cond $ roomRect 100 h 1 1 & rmPmnts .~
[blockLine (V2 50 50) (V2 50 h)
,sPS (V2 25 (h-25)) (negate pi/2) $ PutCrit $ addArmour autoCrit
,sPS (V2 75 (h-80)) 0 putLamp
] ++
[sPS p 0 $ PutCrit explosiveBarrel
| p <- [ V2 75 (h-30) ,V2 75 (h-60) ,V2 85 (h-10) ,V2 85 (h-45) ] ]
return $
restrictInLinks cond $
roomRect 100 h 1 1 & rmPmnts
.~ [ blockLine (V2 50 50) (V2 50 h)
, sPS (V2 25 (h -25)) (negate pi / 2) $ PutCrit $ addArmour autoCrit
, sPS (V2 75 (h -80)) 0 putLamp
]
++ [ sPS p 0 $ PutCrit explosiveBarrel
| p <- [V2 75 (h -30), V2 75 (h -60), V2 85 (h -10), V2 85 (h -45)]
]
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 (280,550)
y2 <- state $ randomR (280,550)
y3 <- iterateWhile (\y' -> abs (y1 - y2) < 60 && abs (y2 - y') < 60) $ state $ randomR (280,560)
x4 <- state $ randomR (60,w-60)
y4 <- state $ randomR (40,150)
let bln x y = putBlockN (x+25) (x-25) (y+20) (y+10)
blv x y = putBlockV (x+25) (x-25) (y+20) (y+10)
plmnts = bln x1 y1 ++ bln x2 y2 ++ bln x3 y3 ++ blv x4 y4
++ [spanLightI (V2 (-10) 200) (V2 (w/2) 200)
,spanLightI (V2 (w/2) 200) (V2 (w+10) 200)
]
toPS x y = return (V2 x y,-0.5*pi)
return $ set rmPmnts plmnts $ roomRectAutoLinks w 600
& rmPmnts .~ plmnts
& rmRandPSs .~ [toPS x1 y1,toPS x2 y2,toPS x3 y3]
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 (280, 550)
y2 <- state $ randomR (280, 550)
y3 <- iterateWhile (\y' -> abs (y1 - y2) < 60 && abs (y2 - y') < 60) $ state $ randomR (280, 560)
x4 <- state $ randomR (60, w -60)
y4 <- state $ randomR (40, 150)
let bln x y = putBlockN (x + 25) (x -25) (y + 20) (y + 10)
blv x y = putBlockV (x + 25) (x -25) (y + 20) (y + 10)
plmnts =
bln x1 y1 ++ bln x2 y2 ++ bln x3 y3 ++ blv x4 y4
++ [ spanLightI (V2 (-10) 200) (V2 (w / 2) 200)
, spanLightI (V2 (w / 2) 200) (V2 (w + 10) 200)
]
toPS x y = return (V2 x y, -0.5 * pi)
return $
set rmPmnts plmnts $
roomRectAutoLinks w 600
& rmPmnts .~ plmnts
& rmRandPSs .~ [toPS x1 y1, toPS x2 y2, toPS x3 y3]
shootersRoom1 :: RandomGen g => State g Room
shootersRoom1 = shootersRoom' <&> rmPmnts .:~ RandomPlacement
(takeOne $ map (\i -> spNoID (PSRoomRand i (uncurry PS)) (PutCrit autoCrit))
[0,1,2])
shootersRoom1 =
shootersRoom' <&> rmPmnts
.:~ RandomPlacement
( takeOne $
map
(\i -> spNoID (PSRoomRand i (uncurry PS)) (PutCrit autoCrit))
[0, 1, 2]
)
shootersRoom :: RandomGen g => State g Room
shootersRoom = shootersRoom' <&> rmPmnts .++~
map (\i -> spNoID (PSRoomRand i (uncurry PS)) (PutCrit autoCrit)) [0,1,2]
shootersRoom =
shootersRoom' <&> rmPmnts
.++~ map (\i -> spNoID (PSRoomRand i (uncurry PS)) (PutCrit autoCrit)) [0, 1, 2]
-- TODO stop from spawning on inlinks fromedge
pistolerRoom :: RandomGen g => State g Room
pistolerRoom = do
(w,wn) <- takeOne [(200,3),(255,4)]
roomPillars 10 w 200 wn 3 <&> rmPmnts .++~ replicate 3
(spNoID (rprBool $ \rp _ -> _rpPlacementUse rp == 0 && rpIsOnPath rp)
(PutCrit pistolCrit))
(w, wn) <- takeOne [(200, 3), (255, 4)]
roomPillars 10 w 200 wn 3 <&> rmPmnts
.++~ replicate
3
( spNoID
(rprBool $ \rp _ -> _rpPlacementUse rp == 0 && rpIsOnPath rp)
(PutCrit pistolCrit)
)
shootingRange :: RandomGen g => State g (MetaTree Room String)
shootingRange = do
rm1 <- shootersRoom1 >>= shuffleLinks . restrictInLinks (\(V2 _ y,_) -> y < 40)
. restrictOutLinks (\(V2 _ y,r) -> y > 200 && r /= 0)
rm2 <- shootersRoom >>= shuffleLinks
. restrictInLinks (\(V2 x y,_) -> y < 10 && x > 20 && x < 180)
. restrictOutLinks (\(V2 _ y,r) -> y > 200 && r /= 0)
rm3 <- shootersRoom >>= shuffleLinks
. restrictInLinks (\(V2 x y,_) -> y < 10 && x > 20 && x < 180)
. restrictOutLinks (\(_,r) -> r == 0)
let padcutroom = roomPadCut (rectNSWE 40 (-40) (-80) 80) (V2 0 20)
& rmPmnts .:~ spanLightI (V2 (-80) 10) (V2 80 10)
rToOnward "shootingRange" $ treePost
[ rm1
, padcutroom
, rm2
, padcutroom
, cleatOnward rm3
]
rm1 <-
shootersRoom1
>>= shuffleLinks . restrictInLinks (\(V2 _ y, _) -> y < 40)
. restrictOutLinks (\(V2 _ y, r) -> y > 200 && r /= 0)
rm2 <-
shootersRoom
>>= shuffleLinks
. restrictInLinks (\(V2 x y, _) -> y < 10 && x > 20 && x < 180)
. restrictOutLinks (\(V2 _ y, r) -> y > 200 && r /= 0)
rm3 <-
shootersRoom
>>= shuffleLinks
. restrictInLinks (\(V2 x y, _) -> y < 10 && x > 20 && x < 180)
. restrictOutLinks (\(_, r) -> r == 0)
let padcutroom =
roomPadCut (rectNSWE 40 (-40) (-80) 80) (V2 0 20)
& rmPmnts .:~ spanLightI (V2 (-80) 10) (V2 80 10)
rToOnward "shootingRange" $
treePost
[ rm1
, padcutroom
, rm2
, padcutroom
, cleatOnward rm3
]
spawnerRoom :: RandomGen g => State g (Tree Room)
spawnerRoom = do
x <- state $ randomR (250,300)
y <- state $ randomR (300,400)
roomWithSpawner <- roomC x y <&> rmPmnts .:~ spNoID
(rprBool $ \rp _ -> _rpPlacementUse rp == 0 && rpIsOnPath rp
&& xV2 (_rpPos rp) < x/2 && yV2 (_rpPos rp) < y/2 )
(PutCrit spawnerCrit)
x <- state $ randomR (250, 300)
y <- state $ randomR (300, 400)
roomWithSpawner <-
roomC x y <&> rmPmnts
.:~ spNoID
( rprBool $ \rp _ ->
_rpPlacementUse rp == 0 && rpIsOnPath rp
&& xV2 (_rpPos rp) < x / 2
&& yV2 (_rpPos rp) < y / 2
)
(PutCrit spawnerCrit)
aRoom <- airlock
return $ treeFromTrunk [ aRoom, corridor] $ pure $ cleatOnward roomWithSpawner
return $ treeFromTrunk [aRoom, corridor] $ pure $ cleatOnward roomWithSpawner
corDoor :: State StdGen (MetaTree Room String)
corDoor = do
cor <- shuffleLinks (cleatOnward corridor) <&> rmPmnts .~ []
return $ tToBTree "corDoor" $ treePost [door,cor]
return $ tToBTree "corDoor" $ treePost [door, cor]
-- cor <- shuffleLinks corridor
-- return $ tToBTree "corDoor" $ treePost [door,cor,cleatOnward door]
src/Dodge/Room/RunPast.hs
+36 -33
View File
@@ -1,54 +1,57 @@
module Dodge.Room.RunPast
( lockedStart
) where
module Dodge.Room.RunPast (
lockedStart,
) where
import Color
import qualified Data.Set as S
import Dodge.Cleat
import Geometry.Polygon
import Dodge.Data.GenWorld
import Dodge.Item.Random
import Dodge.LevelGen.Data
import Dodge.LightSource
import Dodge.Data
import RandomHelp
import Dodge.Placement.Instance
import Dodge.PlacementSpot
import Dodge.Room.Corridor
import Dodge.Room.Door
import Dodge.Room.Link
import Dodge.Room.Procedural
import Dodge.Room.Corridor
import Dodge.PlacementSpot
import Dodge.Placement.Instance
import Dodge.Tree
import Dodge.Item.Random
import Geometry.Data
import Color
import Geometry.Polygon
import LensHelp
import qualified Data.Set as S
import RandomHelp
roomCritLS :: RandomGen g => State g LightSource
roomCritLS = do
col <- takeOne [0.5, 0.6]
h <- takeOne [30,35]
h <- takeOne [30, 35]
rad <- takeOne [300]
return $ lsPosColRad (V3 0 0 h) col rad
smallRoom :: Room
smallRoom = corridorWallN & rmRandPSs .~ [psRandRanges (15,25) (30,45) (pi,2*pi)]
smallRoom = corridorWallN & rmRandPSs .~ [psRandRanges (15, 25) (30, 45) (pi, 2 * pi)]
lockedStart :: RandomGen g => Int -> State g (Tree Room)
lockedStart i = do
h <- state $ randomR (200,400::Float)
thels <- roomCritLS
theweapon <- randBlockBreakWeapon
cenroom <- shuffleLinks $ roomRectAutoLinks 40 h & rmPmnts .~ []
theedge <- takeOne $ map OnEdge [West,East]
let linkcor = smallRoom & rmPmnts .~ [ spanLS thels (V2 0 65) (V2 40 65) ]
h <- state $ randomR (200, 400 :: Float)
thels <- roomCritLS
theweapon <- randBlockBreakWeapon
cenroom <- shuffleLinks $ roomRectAutoLinks 40 h & rmPmnts .~ []
theedge <- takeOne $ map OnEdge [West, East]
let linkcor = smallRoom & rmPmnts .~ [spanLS thels (V2 0 65) (V2 40 65)]
n = length $ filter (elem theedge . _rlType) (_rmLinks cenroom)
doorrooms = map (treePost . (triggerDoorRoom i:))
$ [linkcor & rmPmnts .:~ plRRpt 0 randC1]
: [linkcor,corridor,corridor,cleatOnward door]
: replicate (n-2) [linkcor]
return $ Node cenroom $
map (over root $ rmConnectsTo .~ S.member theedge) doorrooms
++ [return smallRoom
{_rmOutPmnt = [OutPlacement (putLitButOnPosExtTrig red useUnusedLnk) i]
,_rmPmnts = [plRRpt 0 (PutFlIt theweapon)]
,_rmBound = [rectNSWE 70 30 0 40]
}
]
doorrooms =
map (treePost . (triggerDoorRoom i :)) $
[linkcor & rmPmnts .:~ plRRpt 0 randC1] :
[linkcor, corridor, corridor, cleatOnward door] :
replicate (n -2) [linkcor]
return $
Node cenroom $
map (over root $ rmConnectsTo .~ S.member theedge) doorrooms
++ [ return
smallRoom
{ _rmOutPmnt = [OutPlacement (putLitButOnPosExtTrig red useUnusedLnk) i]
, _rmPmnts = [plRRpt 0 (PutFlIt theweapon)]
, _rmBound = [rectNSWE 70 30 0 40]
}
]
src/Dodge/Room/SensorDoor.hs
+44 -37
View File
@@ -1,39 +1,40 @@
--{-# LANGUAGE TupleSections #-}
module Dodge.Room.SensorDoor where
--import Dodge.RoomLink
import qualified Data.Set as S
import Dodge.Annotation.Data
import Dodge.Cleat
import Dodge.Data.GenWorld
import Dodge.LevelGen.Data
import Dodge.Placement.Instance
import Dodge.PlacementSpot
import Dodge.Placement.Instance.Terminal
import Dodge.Terminal
import Dodge.Data
import Dodge.Tree
import Dodge.Wire
--import Dodge.RoomLink
import Dodge.Room.Corridor
import Dodge.Room.Door
import Dodge.Room.Link
import Dodge.Room.Ngon
import Dodge.Room.Procedural
import Dodge.Room.Corridor
import Dodge.Room.Link
import Dodge.Placement.Instance
import Dodge.Terminal
import Dodge.Tree
import Dodge.Wire
import Geometry
import LensHelp
import RandomHelp
import qualified Data.Set as S
-- TODO fix case where the sensor created by sensInsideDoor blocks another door
-- for roomRectAutoLinks-- make the locked door a center door?
sensorRoom :: RandomGen g => DamageType -> Int -> State g (Tree Room)
sensorRoom senseType n = do
rm <- takeOne [roomNgon 8 200, roomRectAutoLinks 200 200]
cenroom <- shuffleLinks $ sensInsideDoor senseType n rm
return $ treePost
[ door
, cenroom & rmLinkEff .~ f
, triggerDoorRoom n
, cleatOnward door
]
return $
treePost
[ door
, cenroom & rmLinkEff .~ f
, triggerDoorRoom n
, cleatOnward door
]
where
f _ _ 0 rl rm = rm & rmLinks %~ map (g (_rlPos rl) (_rlDir rl))
f _ _ _ _ rm = rm
@@ -47,27 +48,33 @@ sensorRoom senseType n = do
sensorRoomRunPast :: RandomGen g => DamageType -> Int -> State g MTRS
sensorRoomRunPast dt n = do
t <- sensorRoom dt n
rToOnward "sensorRoomRunPast" $ t & applyToSubforest [0]
(++
[treePost
[ door & rmConnectsTo .~ (\s -> S.member InLink s && not (S.member BlockedLink s))
, cleatLabel n corridor ]
]
)
rToOnward "sensorRoomRunPast" $
t
& applyToSubforest
[0]
( ++
[ treePost
[ door & rmConnectsTo .~ (\s -> S.member InLink s && not (S.member BlockedLink s))
, cleatLabel n corridor
]
]
)
sensAboveDoor :: DamageType -> Float -> PlacementSpot -> Placement
sensAboveDoor sensetype wth ps = extTrigLitPos
(atFstLnkOutShiftBy (\(p,a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a)))
( \tp -> Just $ damageSensor sensetype wth (_plMID tp) ps )
sensAboveDoor sensetype wth ps =
extTrigLitPos
(atFstLnkOutShiftBy (\(p, a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a)))
(\tp -> Just $ damageSensor sensetype wth (_plMID tp) ps)
sensInsideDoor :: DamageType -> Int -> Room -> Room
sensInsideDoor senseType outplid rm = rm
& rmName .++~ take 4 (show senseType)
& rmPmnts .++~
[ psPt atFstLnkOut . PutForeground $ floorWire (V2 20 0) (V2 20 (-100))
, psPt atFstLnkOut . PutForeground $ floorWire (V2 0 (-100)) (V2 20 (-100))
, psPt atFstLnkOut . PutForeground $ verticalWire (V2 20 0) 0 80
, putMessageTerminal terminalColor (basicTerminal & tmScrollCommands .:~ damageCodeCommand)
& plSpot .~ rprBoolShift isUnusedLnk (shiftInBy 10)
]
& rmOutPmnt .~ [OutPlacement (sensAboveDoor senseType 10 (atFstLnkOutShiftInward 100)) outplid]
sensInsideDoor senseType outplid rm =
rm
& rmName .++~ take 4 (show senseType)
& rmPmnts
.++~ [ psPt atFstLnkOut . PutForeground $ floorWire (V2 20 0) (V2 20 (-100))
, psPt atFstLnkOut . PutForeground $ floorWire (V2 0 (-100)) (V2 20 (-100))
, psPt atFstLnkOut . PutForeground $ verticalWire (V2 20 0) 0 80
, putMessageTerminal terminalColor (basicTerminal & tmScrollCommands .:~ damageCodeCommand)
& plSpot .~ rprBoolShift isUnusedLnk (shiftInBy 10)
]
& rmOutPmnt .~ [OutPlacement (sensAboveDoor senseType 10 (atFstLnkOutShiftInward 100)) outplid]
src/Dodge/Room/Start.hs
+68 -57
View File
@@ -1,33 +1,31 @@
{-# LANGUAGE TupleSections #-}
module Dodge.Room.Start
( startRoom
, randomChallenges
) where
module Dodge.Room.Start (
startRoom,
randomChallenges,
) where
import Dodge.Item.Held.Cane
import Dodge.Item.Held.Launcher
import Dodge.Cleat
import Dodge.Data
import Dodge.LevelGen.Data
--import Dodge.PlacementSpot
import Dodge.Room.RunPast
import Dodge.Room.Containing
--import Dodge.Room.LongDoor
--import Dodge.RoomLink
--import Dodge.Data
--import Dodge.Default
--import Dodge.RoomLink
import Dodge.Tree
import RandomHelp
import Dodge.Room.Door
import Dodge.Room.RezBox
import Dodge.Room.Corridor
import Dodge.Room.Room
import Dodge.Room.Link
import Dodge.Item.Weapon
import Dodge.Data.GenWorld
import Dodge.Item.Craftable
import Dodge.Item.Weapon
import Dodge.LevelGen.Data
import Dodge.Room.Containing
import Dodge.Room.Corridor
import Dodge.Room.Door
import Dodge.Room.Link
import Dodge.Room.RezBox
import Dodge.Room.Room
import Dodge.Room.RunPast
import Dodge.Tree
--import Dodge.LevelGen.Data
--import Geometry.Data
--import Padding
--import Shape
import LensHelp
import RandomHelp
--import Data.Maybe
--import Data.Tree
@@ -38,33 +36,42 @@ powerFakeout' = tToBTree "powerFakeout'" <$> powerFakeout
powerFakeout :: RandomGen g => State g (Tree Room)
powerFakeout = do
ncor <- state $ randomR (0,2)
it <- takeOne
[miniGunX 6
,launcherX 7
]
ncor <- state $ randomR (0, 2)
it <-
takeOne
[ miniGunX 6
, launcherX 7
]
roomwithmini <- pedestalRoom it
randcors <- replicateM ncor $ shuffleLinks corridor
return $ treePost $
[ corridor,door
, roomwithmini
, door
]
++ randcors
++ [ corridor & rmPmnts .:~ plRRpt 0 (PutFlIt shrinkGun)
, keyholeCorridor, corridor
,cleatOnward door]
return $
treePost $
[ corridor
, door
, roomwithmini
, door
]
++ randcors
++ [ corridor & rmPmnts .:~ plRRpt 0 (PutFlIt shrinkGun)
, keyholeCorridor
, corridor
, cleatOnward door
]
-- the i is used either for a PickOnePlacement or a room id, this is not great
startRoom :: Int -> State StdGen (MetaTree Room String)
startRoom i = join $ takeOne
[ attachOnward "startThenWeaponRoom" <$> preCritStart <*> weaponRoom i
, rezBoxesWpCrit >>= rToOnward "rezBoxesWpCrit"
, runPastStart i >>= rToOnward ("runPastStart " ++ show i)
, attachOnward "startThenCraft" <$> preCritStart <*> (startCrafts >>= roomsContaining [])
]
startRoom i =
join $
takeOne
[ attachOnward "startThenWeaponRoom" <$> preCritStart <*> weaponRoom i
, rezBoxesWpCrit >>= rToOnward "rezBoxesWpCrit"
, runPastStart i >>= rToOnward ("runPastStart " ++ show i)
, attachOnward "startThenCraft" <$> preCritStart <*> (startCrafts >>= roomsContaining [])
]
randomChallenges :: RandomGen g => State g (MetaTree Room String)
randomChallenges = shootingRange
-- join (takeOne
-- [fmap (return . useAll) doubleCorridorBarrels <&> (,TreeSubLabelling "doubleCorridorBarrels" Nothing)
-- ,shootingRange
@@ -76,26 +83,30 @@ runPastStart i = do
s <- rezBoxStart
rp <- lockedStart i
return . shiftChildren $ attachTree toOnward rp $ fmap ([],) s
rezBoxStart :: RandomGen g => State g (Tree Room)
rezBoxStart = do
ls <- rezColor
return $ treePost [ rezBox ls, cleatOnward door ]
return $ treePost [rezBox ls, cleatOnward door]
preCritStart :: RandomGen g => State g (MetaTree Room String)
preCritStart = join $ takeOneWeighted
[100,100,1::Float]
[rezBoxes
,rezBox'
,attachOnward "rezBoxPowerFakeout" <$> rezBox' <*> powerFakeout'
]
preCritStart =
join $
takeOneWeighted
[100, 100, 1 :: Float]
[ rezBoxes
, rezBox'
, attachOnward "rezBoxPowerFakeout" <$> rezBox' <*> powerFakeout'
]
startCrafts :: RandomGen g => State g [Item]
startCrafts = takeOne $ map (map makeTypeCraft)
[ [PIPE,PIPE,HARDWARE]
, [TUBE,PIPE,HARDWARE]
, [PIPE,HARDWARE,HARDWARE]
, [TUBE,TUBE,HARDWARE]
, [TUBE,HARDWARE,HARDWARE]
]
startCrafts =
takeOne $
map
(map makeTypeCraft)
[ [PIPE, PIPE, HARDWARE]
, [TUBE, PIPE, HARDWARE]
, [PIPE, HARDWARE, HARDWARE]
, [TUBE, TUBE, HARDWARE]
, [TUBE, HARDWARE, HARDWARE]
]
src/Dodge/Room/Tanks.hs
+93 -56
View File
@@ -1,92 +1,129 @@
module Dodge.Room.Tanks where
import Dodge.Data
import Dodge.Placement.Instance.Pipe
import Color
import Dodge.Base.CardinalPoint
import Dodge.Data.GenWorld
import Dodge.LevelGen.Data
import RandomHelp
import Dodge.Room.Procedural
import Dodge.Room.Foreground
import Dodge.Room.Modify.Girder
--import Dodge.Room.RoadBlock
import Dodge.Placement.Instance
import Dodge.Placement.Instance.Pipe
import Dodge.Placement.TopDecoration
import Dodge.PlacementSpot
import Dodge.Base.CardinalPoint
--import Padding
import Color
import Shape
import LensHelp
import Dodge.Room.Foreground
import Dodge.Room.Modify.Girder
import Dodge.Room.Procedural
import Geometry
import LensHelp
import RandomHelp
import Shape
--import Data.Maybe
--import Data.Tree
--import qualified Data.Set as S
randomTank :: RandomGen g => State g Placement
randomTank = takeOne $ map (\f -> f (dim orange) orange)
[ tankSquareDec fourEmbossDecoration
, tankSquareDec midBarDecoration
, tankSquareDec squareDecoration
, roundTank
, roundTankCross
, tankSquareDec plusDecoration
]
randomTank =
takeOne $
map
(\f -> f (dim orange) orange)
[ tankSquareDec fourEmbossDecoration
, tankSquareDec midBarDecoration
, tankSquareDec squareDecoration
, roundTank
, roundTankCross
, tankSquareDec plusDecoration
]
-- dup with randEdgeTanks?
randEdgeTank :: RandomGen g => State g Placement
randEdgeTank = do
edge <- takeOne cardList
basetank <- randomTank
return $ basetank
& plType . putBlock . blDraw
%~ ( \bd -> BlockDraws [bd, BlockDrawBlSh (BlShConst $ colorSH orange (verticalPipe 80
<> horPipe 80 0 (70 *.* cardVec edge)))] )
-- %~ fmap (<> noPic ( colorSH orange (verticalPipe 80
-- <> horPipe 80 0 (70 *.* cardVec edge))))
-- 70 is a guess, the true value depends on the distance to the wall
& plSpot .~ rprBool (\rp _ -> _rpPlacementUse rp == 0
&& rpOffPathFromEdge (PathFromEdge edge 0) rp)
return $
basetank
& plType . putBlock . blDraw
%~ ( \bd ->
BlockDraws
[ bd
, BlockDrawBlSh
( BlShConst $
colorSH
orange
( verticalPipe 80
<> horPipe 80 0 (70 *.* cardVec edge)
)
)
]
)
-- %~ fmap (<> noPic ( colorSH orange (verticalPipe 80
-- <> horPipe 80 0 (70 *.* cardVec edge))))
-- 70 is a guess, the true value depends on the distance to the wall
& plSpot
.~ rprBool
( \rp _ ->
_rpPlacementUse rp == 0
&& rpOffPathFromEdge (PathFromEdge edge 0) rp
)
randEdgeTanks :: RandomGen g => Int -> State g [Placement]
randEdgeTanks i = do
edge <- takeOne cardList
basetank <- randomTank
return $ replicate i $ basetank
& plType . putBlock . blDraw
%~ ( \bd -> BlockDraws [bd, BlockDrawBlSh (BlShConst $ colorSH orange (verticalPipe 80
<> horPipe 80 0 (70 *.* cardVec edge)))] )
-- 70 is a guess, the true value depends on the distance to the wall
& plSpot .~ rprBool (\rp _ -> _rpPlacementUse rp == 0
&& rpOffPathFromEdge (PathFromEdge edge 0) rp)
return $
replicate i $
basetank
& plType . putBlock . blDraw
%~ ( \bd ->
BlockDraws
[ bd
, BlockDrawBlSh
( BlShConst $
colorSH
orange
( verticalPipe 80
<> horPipe 80 0 (70 *.* cardVec edge)
)
)
]
)
-- 70 is a guess, the true value depends on the distance to the wall
& plSpot
.~ rprBool
( \rp _ ->
_rpPlacementUse rp == 0
&& rpOffPathFromEdge (PathFromEdge edge 0) rp
)
tanksPipesRoom :: RandomGen g => State g Room
tanksPipesRoom = do
w <- state $ randomR (200,300)
h <- state $ randomR (200,300)
i <- state $ randomR (2,5)
w <- state $ randomR (200, 300)
h <- state $ randomR (200, 300)
i <- state $ randomR (2, 5)
tanks <- randEdgeTanks i
return $ roomRectAutoLinks w h & rmPmnts .++~ tanks
tanksRoom :: RandomGen g => [Creature] -> [Item] -> State g Room
tanksRoom crs its = do
w <- state $ randomR (100,400)
h <- state $ randomR (200,400)
ntanks <- state $ randomR (3,6)
w <- state $ randomR (100, 400)
h <- state $ randomR (200, 400)
ntanks <- state $ randomR (3, 6)
thetank <- randomTank <&> plSpot .~ unusedOffPathAwayFromLink 50
let room = roomRectAutoLinks w h
let plmnts =
let plmnts =
map (\it -> sps0 (PutFlIt it) & plSpot .~ anyUnusedSpot) its
++ map (\cr -> sps0 (PutCrit cr) & plSpot .~ unusedSpotAwayFromLink 50) crs
++ replicate ntanks thetank
++ [mntLightLnkCond $ resetPLUse $ rprBool $ \rp _ -> isOutLnk rp]
-- , sps0 $ PutShape $ colorSH orange $ pipePP 2 (V3 50 50 25) (V3 50 120 25)
++ map (\cr -> sps0 (PutCrit cr) & plSpot .~ unusedSpotAwayFromLink 50) crs
++ replicate ntanks thetank
++ [mntLightLnkCond $ resetPLUse $ rprBool $ \rp _ -> isOutLnk rp]
-- , sps0 $ PutShape $ colorSH orange $ pipePP 2 (V3 50 50 25) (V3 50 120 25)
hgshape <- takeOne [girder 96 20 10, girderZ 96 20 10, girderV 96 20 10]
addhighgirds <- takeOne $
[ addGirderEW hgshape black >=> addGirderEW hgshape black
, addGirderEW hgshape black
, addGirderNS hgshape black >=> addGirderNS hgshape black
, addGirderNS hgshape black
] ++ replicate 4 return
addhighgirds <-
takeOne $
[ addGirderEW hgshape black >=> addGirderEW hgshape black
, addGirderEW hgshape black
, addGirderNS hgshape black >=> addGirderNS hgshape black
, addGirderNS hgshape black
]
++ replicate 4 return
lgshape <- takeOne [girder 60 20 10, girderZ 60 20 10, girderV 60 20 10]
addlowgirds <- takeOne $ addGirderNS lgshape red : replicate 4 return
(addlowgirds >=> addhighgirds) $ room & rmPmnts .++~ plmnts
& rmName .~ "tanksRoom"
addlowgirds <- takeOne $ addGirderNS lgshape red : replicate 4 return
(addlowgirds >=> addhighgirds) $
room & rmPmnts .++~ plmnts
& rmName .~ "tanksRoom"
src/Dodge/Room/Teleport.hs
+28 -27
View File
@@ -1,36 +1,37 @@
{- Specification of rooms that teleport (between levels). -}
module Dodge.Room.Teleport
where
import Dodge.Data
import Dodge.LevelGen.Data
import Dodge.Room.Procedural
import Dodge.Placement.Instance
--import Dodge.LevelGen.Data
import Geometry
import Picture
module Dodge.Room.Teleport where
import Control.Lens
import Control.Monad.State
import Dodge.Data.GenWorld
import Dodge.LevelGen.Data
import Dodge.Placement.Instance
import Dodge.Room.Procedural
import Geometry
import Picture
import System.Random
telRoomLev
:: RandomGen g
=> Int -- ^ Level number to teleport to
-> State g Room
telRoomLev ::
RandomGen g =>
-- | Level number to teleport to
Int ->
State g Room
telRoomLev _ = do
w <- state $ randomR (200,300)
h <- state $ randomR (200,300)
return $ roomRectAutoLinks w h & rmPmnts .~
[ sPS (V2 (w/2) (h/2)) 0 $ PutPPlate telPP
, sPS (V2 (w/2) (h/2+ 30)) 0 putLamp
]
w <- state $ randomR (200, 300)
h <- state $ randomR (200, 300)
return $
roomRectAutoLinks w h & rmPmnts
.~ [ sPS (V2 (w / 2) (h / 2)) 0 $ PutPPlate telPP
, sPS (V2 (w / 2) (h / 2 + 30)) 0 putLamp
]
where
telPP = PressPlate
{ _ppPict = setDepth 0.5 . color red $ polygon ppFootprint
, _ppPos = V2 0 0
, _ppRot = 0
, _ppEvent = PPLevelReset
, _ppID = 0
, _ppText = "NEW LEVEL"
}
telPP =
PressPlate
{ _ppPict = setDepth 0.5 . color red $ polygon ppFootprint
, _ppPos = V2 0 0
, _ppRot = 0
, _ppEvent = PPLevelReset
, _ppID = 0
, _ppText = "NEW LEVEL"
}
ppFootprint = reverse $ rectNSWE 20 (-20) (-20) 20
src/Dodge/Room/Treasure.hs
+47 -40
View File
@@ -2,52 +2,59 @@
Rooms that contain valuable items, typically protected in some manner.
Typically dead ends.
-}
module Dodge.Room.Treasure
where
import Dodge.Data
import Dodge.RoomLink
import Dodge.Placement.Instance
module Dodge.Room.Treasure where
import Control.Monad.State
import Dodge.Data.GenWorld
import Dodge.Default.Room
import Dodge.LevelGen.Data
import Dodge.Placement.Instance
import Dodge.RoomLink
import Geometry
--import Data.List
import Control.Monad.State
--import Control.Lens
--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. -}
triLootRoom
:: Float -- Width
-> Float -- Height
-> State g Room
triLootRoom w h = pure $ defaultRoom
{ _rmPolys = [ tri
, base
]
, _rmLinks = [uncurry inLink(V2 0 (-80) , pi)]
, _rmPath = doublePairSet (V2 0 (-80) , V2 0 (h/2))
, _rmPmnts =
[sPS (V2 (15-w) 15 ) 0 $ PutID 0
,sPS (V2 (w-15) 15 ) pi $ PutID 0
,sPS (V2 0 (h-35)) 0 $ PutID 2
,mntLS vShape (V2 0 (h-20)) (V3 0 (h-80) 70)
,sPS (V2 0 ( -60)) 0 putLamp
]
, _rmBound = [tri , base]
}
--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.
-}
triLootRoom ::
Float -> -- Width
Float -> -- Height
State g Room
triLootRoom w h =
pure $
defaultRoom
{ _rmPolys =
[ tri
, base
]
, _rmLinks = [uncurry inLink (V2 0 (-80), pi)]
, _rmPath = doublePairSet (V2 0 (-80), V2 0 (h / 2))
, _rmPmnts =
[ sPS (V2 (15 - w) 15) 0 $ PutID 0
, sPS (V2 (w -15) 15) pi $ PutID 0
, sPS (V2 0 (h -35)) 0 $ PutID 2
, mntLS vShape (V2 0 (h -20)) (V3 0 (h -80) 70)
, sPS (V2 0 (-60)) 0 putLamp
]
, _rmBound = [tri, base]
}
where
tri = map toV2
[ ( -w,30)
, ( -w, 0)
, ( w, 0)
, ( w,30)
, ( 20, h)
, (-20, h)
]
base = rectNSWE 20 (-80) (-20) 20
{- | Create a random room with one entrance containing given creatures and items. -}
tri =
map
toV2
[ (- w, 30)
, (- w, 0)
, (w, 0)
, (w, 30)
, (20, h)
, (-20, h)
]
base = rectNSWE 20 (-80) (-20) 20
-- | Create a random room with one entrance containing given creatures and items.
lootRoom :: [Creature] -> [Item] -> State g Room
lootRoom crs itms = do
let w = 300
src/Dodge/Room/Warning.hs
+37 -31
View File
@@ -1,63 +1,69 @@
--{-# LANGUAGE TupleSections #-}
module Dodge.Room.Warning where
import Dodge.WorldEffect
import Color
--import qualified Data.Set as S
import qualified Data.Map.Strict as M
import Data.Maybe
import Dodge.Cleat
import Dodge.Terminal
import Dodge.Data.GenWorld
import Dodge.Placement.Instance
import Dodge.PlacementSpot
import Dodge.Placement.Instance.Terminal
import Dodge.Data
import Dodge.Tree
import Dodge.Room.Door
import Dodge.Room.Link
import Dodge.Room.Ngon
import Dodge.Room.Procedural
import Dodge.Room.Tanks
import Dodge.Room.Link
import Dodge.Placement.Instance
import Dodge.Terminal
import Dodge.Tree
import Dodge.WorldEffect
import Geometry
import Color
import LensHelp
import RandomHelp
--import qualified Data.Set as S
import Data.Maybe
import qualified Data.Map.Strict as M
--import Data.Char
--import Data.Tree
--import qualified Data.Text as T
warningRooms :: RandomGen g => String -> Int -> State g (MetaTree Room String)
warningRooms str n = do
rm <- do
tr <- tanksRoom [] []
takeOne [roomNgon 8 200, roomRectAutoLinks 200 200,tr]
takeOne [roomNgon 8 200, roomRectAutoLinks 200 200, tr]
cenroom <- shuffleLinks $ addWarningTerminal str n rm
rToOnward "warningRooms" $ treePost [ door, cenroom, triggerDoorRoom n, cleatOnward door]
rToOnward "warningRooms" $ treePost [door, cenroom, triggerDoorRoom n, cleatOnward door]
addWarningTerminal :: String -> Int -> Room -> Room
addWarningTerminal str outplid = (rmName .++~ "warningTerm-")
. (rmOutPmnt .~ [OutPlacement outplace outplid])
addWarningTerminal str outplid =
(rmName .++~ "warningTerm-")
. (rmOutPmnt .~ [OutPlacement outplace outplid])
where
outplace = extTrigLitPos
(atFstLnkOutShiftBy (\(p,a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a)))
(Just . set plSpot (rprShift moveToSideFirstOutLink)
. putMessageTerminal terminalColor . termMessages)
termMessages trpl = lineOutputTerminal (makeColorTermLine red "WARNING":makeTermPara str)
& tmScrollCommands .:~ toggleCommand
& tmToggles .~ M.fromList
[("DOOR",TerminalToggle (fromJust $ _plMID trpl) (BlConst True))]
outplace =
extTrigLitPos
(atFstLnkOutShiftBy (\(p, a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a)))
( Just . set plSpot (rprShift moveToSideFirstOutLink)
. putMessageTerminal terminalColor
. termMessages
)
termMessages trpl =
lineOutputTerminal (makeColorTermLine red "WARNING" : makeTermPara str)
& tmScrollCommands .:~ toggleCommand
& tmToggles
.~ M.fromList
[("DOOR", TerminalToggle (fromJust $ _plMID trpl) (BlConst True))]
moveToSideFirstOutLink :: RoomPos -> Room -> Maybe (Point2,Float)
moveToSideFirstOutLink :: RoomPos -> Room -> Maybe (Point2, Float)
moveToSideFirstOutLink rp rm = case rp ^? rpLinkStatus . rplsChildNum of
Just 0 ->
Just 0 ->
let rppos = _rpPos rp
rpdir = _rpDir rp
inpos = rppos +.+ rotateV rpdir (V2 0 (-12.5))
rtpos = inpos +.+ rotateV rpdir (V2 30 0)
ltpos = inpos +.+ rotateV rpdir (V2 (-30) 0)
in if any (isJust . intersectSegPolyFirst inpos ltpos) (_rmPolys rm)
-- the above test may not work properly if the room polys are
-- complicated, it should really use created walls...
then Just (rtpos, rpdir)
else Just (ltpos, rpdir)
in if any (isJust . intersectSegPolyFirst inpos ltpos) (_rmPolys rm)
then -- the above test may not work properly if the room polys are
-- complicated, it should really use created walls...
Just (rtpos, rpdir)
else Just (ltpos, rpdir)
_ -> Nothing