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

Add log when generating layout

Browse Source
This commit is contained in:
justin
2022-05-20 21:15:44 +01:00
parent 20d041fc59
commit da302aad0c
16 changed files with 155 additions and 94 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Annotation.hs
+18 -13
View File
@@ -37,8 +37,9 @@ padSucWithDoors (Node x xs) = Node x (map (padWithAno [SpecificRoom thetree]) xs
thetree = do
thecor <- shuffleLinks corridor
takeOne
[ return (UseAll door)
, treeFromPost [PassDown door, PassDown thecor] (UseAll door)
[ (return (UseAll door),TreeSubLabelling "door" Nothing)
, (treeFromPost [PassDown door, PassDown thecor] (UseAll door)
,TreeSubLabelling "twoDoors" Nothing)
]
{- Add one to three corridors between each parent-child link of a tree of annotations. -}
@@ -54,30 +55,34 @@ roomThenCorridor theRoom = fmap
(shuffleLinks corridor)
{- | Create a random room tree structure from a list of annotations. -}
anoToRoomTree :: [Annotation] -> State StdGen (SubCompTree Room,String)
anoToRoomTree :: [Annotation] -> State StdGen (LabSubCompTree Room)
anoToRoomTree anos = case anos of
[AnoApplyInt i f] -> f i
[AnoApplyInt' i f str] -> f i <&> (,str)
_ -> fmap (,"") $ anoToRoomTree' anos
-- [AnoApplyInt' i f str] -> f i <&> (,TreeSubLabelling str Nothing)
(SpecificRoom rt:_) -> rt
[PassthroughLockKeyLists i ls ks] -> do
(functionlockroom,randomitemidentity) <- takeOne ls
lr' <- functionlockroom i
ii <- randomitemidentity
let lr = fst lr'
keyroom' <- fromJust $ lookup ii ks
let keyroom = fst keyroom'
(return $ overwriteLabel 0 UseNone lr [keyroom]
) <&> (,TreeSubLabelling ("PassthroughLockKeyLists-"++show ii)
(Just $ treeFromPost [snd lr'] (snd keyroom'))
)
_ -> (,TreeSubLabelling "" Nothing) <$> anoToRoomTree' anos
{- | Create a random room tree structure from a list of annotations. -}
anoToRoomTree' :: [Annotation] -> State StdGen (SubCompTree Room)
anoToRoomTree' anos = case anos of
-- [AnoApplyInt i f] -> f i
[ChainAnos ass] -> do
rms <- mapM anoToRoomTree' ass
return $ chainUses rms
[PassthroughLockKeyLists i ls ks] -> do
(functionlockroom,randomitemidentity) <- takeOne ls
lr <- functionlockroom i
ii <- randomitemidentity
keyroom <- fromJust $ lookup ii ks
return $ overwriteLabel 0 UseNone lr [keyroom]
[OrAno as] -> do
a <- takeOne as
anoToRoomTree' a
[Corridor] -> pure . UseAll <$> shuffleLinks corridor
(SpecificRoom rt:_) -> rt
(BossAno cr : _) -> do
br <- bossRoom cr
branchRectWith . pure . fmap PassDown $ treeFromPost [corridor,corridor] br
src/Dodge/Annotation/Data.hs
+4 -5
View File
@@ -14,15 +14,14 @@ data Annotation
| Corridor
| AirlockAno
| OrAno [[Annotation]]
| SpecificRoom (State StdGen (SubCompTree Room))
| SpecificRoom (State StdGen (LabSubCompTree Room))
| BossAno Creature
| TreasureAno [Creature] [Item]
| AnoApplyInt Int (Int -> State StdGen (SubCompTree Room,String))
| AnoApplyInt' Int (Int -> State StdGen (SubCompTree Room)) String
| AnoApplyInt Int (Int -> State StdGen (LabSubCompTree Room))
| AnoNewInt (Int -> State StdGen (SubCompTree Room))
| PassthroughLockKeyLists Int
[(Int -> State StdGen (SubCompTree Room), State StdGen CombineType)]
[(CombineType, State StdGen (SubCompTree Room))]
[(Int -> State StdGen (LabSubCompTree Room), State StdGen CombineType)]
[(CombineType, State StdGen (LabSubCompTree Room))]
-- | SetLabel Int (State g Room)
-- | UseLabel Int (State g Room)
| ChainAnos [[Annotation]]
src/Dodge/Floor.hs
+11 -6
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE TupleSections #-}
--{-# OPTIONS_GHC -Wno-unused-imports #-}
{- | The tree of rooms that make up a level. -}
module Dodge.Floor
@@ -38,16 +39,18 @@ import System.Random
initialAnoTree :: Tree [Annotation]
initialAnoTree = padSucWithDoors $ treeFromTrunk
[[AnoApplyInt 0 startRoom]
, [SpecificRoom $ return . return . UseAll $ roomRectAutoLinks 400 400
, [SpecificRoom $ return (return . UseAll $ roomRectAutoLinks 400 400
& rmPmnts .++~ [spNoID anyUnusedSpot (PutCrit chaseCrit)
, spNoID anyUnusedSpot (PutCrit armourChaseCrit)
]
, TreeSubLabelling "chaseCrit+armourChaseCrit rectRoom" Nothing)
]
-- , [AnoApplyInt 100 healthTest]
, [SpecificRoom $ return . UseAll <$> tanksRoom [] []]
, [SpecificRoom ((return . UseAll <$> tanksRoom [] [])
<&> (, TreeSubLabelling "empty tanksRoom" Nothing))]
, [PassthroughLockKeyLists 2 lockRoomKeyItems itemRooms]
, [SpecificRoom randomChallenges]
, [AnoApplyInt' 1 lasSensorTurretTest "lasSensorTurretTest"]
, [AnoApplyInt 1 lasSensorTurretTest]
-- ,[SpecificRoom $ fmap singleUseAll roomCCrits]
-- ,[AirlockAno]
-- ,[Corridor]
@@ -88,11 +91,13 @@ initialAnoTree = padSucWithDoors $ treeFromTrunk
-- ,[Corridor]
-- ,[TreasureAno [addArmour autoCrit,addArmour autoCrit] [launcher]]
]
$ treeFromPost [[Corridor,SpecificRoom $ pure . UseAll <$> randomFourCornerRoom []]]
[SpecificRoom $ fmap (pure . UseAll) (telRoomLev 1)]
$ treeFromPost [[Corridor,SpecificRoom $ (pure . UseAll <$> randomFourCornerRoom [])
<&>(,TreeSubLabelling "randomFourCornerRoom" Nothing )]]
[SpecificRoom $ (fmap (pure . UseAll) (telRoomLev 1))
<&> (,TreeSubLabelling "telRoomLev" Nothing)]
{- | A test level tree. -}
initialRoomTree :: State StdGen (Tree (SubCompTree Room,String))
initialRoomTree :: State StdGen (Tree (LabSubCompTree Room))
initialRoomTree = mapM anoToRoomTree initialAnoTree
--initialRoomTree :: State StdGen (Tree Room)
--initialRoomTree = do
src/Dodge/LevelGen.hs
+9 -1
View File
@@ -34,7 +34,7 @@ layoutLevelFromSeed i seed = do
let g = mkStdGen seed
let treecluster = evalState initialRoomTree g
putStrLn "Room cluster layout:"
putStrLn $ drawTree $ fmap snd treecluster
putStrLn $ drawTreeSubLabelling $ fmap snd treecluster
let rmtree = inorderNumberTree $ expandTree $ fmap fst treecluster
putStrLn "Room layout (compact): "
putStrLn $ compactDrawTree $ fmap (show . snd) rmtree
@@ -55,6 +55,14 @@ layoutLevelFromSeed i seed = do
let (seed',_) = random g
layoutLevelFromSeed i' seed'
drawTreeSubLabelling :: Tree TreeSubLabelling -> String
drawTreeSubLabelling t = drawTree (fmap _topLabel t)
++ concat
(map f $ flatten t)
where
f (TreeSubLabelling _ Nothing) = ""
f (TreeSubLabelling l (Just t')) = l ++ ":\n" ++ drawTreeSubLabelling t'
reversePair :: (a,b) -> (b,a)
reversePair (a,b) = (b,a)
src/Dodge/LockAndKey.hs
+7 -4
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE TupleSections #-}
module Dodge.LockAndKey where
import Dodge.Data
import Dodge.Tree
@@ -8,6 +9,7 @@ import Dodge.Creature
import Dodge.Item.Craftable
import Dodge.Item.Weapon.BulletGun.Rod
import Dodge.Item
import LensHelp
--import Dodge.Item.Equipment
import System.Random
@@ -18,7 +20,7 @@ bossKeyItems =
[(return . UseAll <$> bossRoom autoCrit, takeOne [PISTOL])
]
lockRoomKeyItems :: RandomGen g => [ (Int -> State g (SubCompTree Room) , State g CombineType ) ]
lockRoomKeyItems :: RandomGen g => [ (Int -> State g (LabSubCompTree Room) , State g CombineType ) ]
lockRoomKeyItems =
[(lasCenSensEdge, takeOne [LAUNCHER,LASGUN,SPARKGUN,FLATSHIELD] )
,(sensorRoomRunPast Electrical, takeOne [STATICMODULE,SPARKGUN] )
@@ -31,7 +33,7 @@ lockRoomKeyItems =
,(keyCardRoomRunPast 0, return (KEYCARD 0))
]
itemRooms :: RandomGen g => [(CombineType, State g (SubCompTree Room))]
itemRooms :: RandomGen g => [(CombineType, State g (LabSubCompTree Room))]
itemRooms =
[ (LAUNCHER , join $ takeOne
[corridorBoss launcherCrit
@@ -95,9 +97,10 @@ someCrits = do
-- return $ roomsContaining crits its
corridorBoss :: RandomGen g => Creature -> State g (SubCompTree Room)
corridorBoss :: RandomGen g => Creature -> State g (LabSubCompTree Room)
corridorBoss cr = do
endroom <- bossRoom cr
return $ treeFromPost (replicate 5 $ PassDown corridor)
(return $ treeFromPost (replicate 5 $ PassDown corridor)
(PassDown endroom)
) <&> (,TreeSubLabelling "corridorBoss" Nothing)
src/Dodge/Room/Containing.hs
+3 -2
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE TupleSections #-}
module Dodge.Room.Containing where
import Dodge.Data
import Dodge.Tree
@@ -14,13 +15,13 @@ import Geometry
import System.Random
import Control.Monad.State
roomsContaining :: RandomGen g => [Creature] -> [Item] -> State g (SubCompTree Room)
roomsContaining :: RandomGen g => [Creature] -> [Item] -> State g (LabSubCompTree Room)
roomsContaining crs its = do
endroom <- join $ takeOne
[ randomFourCornerRoomCrsIts crs its
, tanksRoom crs its
]
return $ treeFromPost [] $ UseAll endroom
(return $ treeFromPost [] $ UseAll endroom) <&> (,TreeSubLabelling "roomsContaining" Nothing)
pedestalRoom :: RandomGen g => Item -> State g Room
pedestalRoom it = do
src/Dodge/Room/Corridor.hs
+3
View File
@@ -59,6 +59,7 @@ corridorN = defaultRoom
, _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)
@@ -88,6 +89,7 @@ tEast = defaultRoom
, _rmPath = concatMap (doublePair . (,) (V2 0 60) . fst) lnks
, _rmPmnts = []
, _rmBound = [ rectNSWE 70 10 0 40 ]
, _rmName = "tEast"
}
where
lnks =
@@ -109,6 +111,7 @@ tWest = defaultRoom
, _rmPath = concatMap (doublePair . (V2 0 60 ,) . _rlPos) lnks
, _rmPmnts = []
, _rmBound = [ rectNSWE 70 10 0 40 ]
, _rmName = "tWest"
}
where
lnks =
src/Dodge/Room/GlassLesson.hs
+3 -2
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE TupleSections #-}
module Dodge.Room.GlassLesson where
import Dodge.RoomLink
import Dodge.Creature
@@ -54,7 +55,7 @@ glassLesson = do
, mntLS vShape (V2 180 200) (V3 160 180 50)
]
]
glassLessonRunPast :: RandomGen g => State g (SubCompTree Room)
glassLessonRunPast = f <$> glassLesson
glassLessonRunPast :: RandomGen g => State g (LabSubCompTree Room)
glassLessonRunPast = (f <$> glassLesson) <&> (,TreeSubLabelling "glassLessonRunPast" Nothing)
where
f (Node r rs) = Node r $ return (UseLabel 0 $ door & rmConnectsTo .~ S.member (OnEdge West)) : rs
src/Dodge/Room/LasTurret.hs
+14 -11
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE TupleSections #-}
module Dodge.Room.LasTurret where
import Dodge.LevelGen.Data
import Dodge.PlacementSpot
@@ -72,14 +73,14 @@ lightSensByDoor outplid rm = rm
covershape = rectNSEW 10 (-10) 20 (-20)
sensorshift (p,a) = (p +.+ rotateV a (V2 60 (-20)), a)
keyCardRoomRunPast :: RandomGen g => Int -> Int -> State g (SubCompTree Room)
keyCardRoomRunPast :: RandomGen g => Int -> Int -> State g (LabSubCompTree Room)
keyCardRoomRunPast keyid rmid = do
cenroom <- shuffleLinks $ keyCardAnalyserByDoor keyid rmid $ roomNgon 6 200
let doorroom = triggerDoorRoom rmid
return $ treeFromTrunk [PassDown door] $ Node (PassDown cenroom)
(return $ treeFromTrunk [PassDown door] $ Node (PassDown cenroom)
[ treeFromPost [PassDown doorroom] (UseAll door)
, treeFromPost [PassDown door] (UseLabel 0 corridor)
]
]) <&> (,TreeSubLabelling "keyCardRoomRunPast" Nothing)
keyCardAnalyserByDoor :: Int -> Int -> Room -> Room
keyCardAnalyserByDoor keyid = analyserByDoor
@@ -133,20 +134,22 @@ healthTest n = do
,PassDown $ corridor & rmPmnts .:~ spNoID (PS 20 0) (PutFlIt (medkit 100))
,PassDown cenroom,PassDown doorroom] (UseAll door)
lasSensorTurretTest :: RandomGen g => Int -> State g (SubCompTree Room)
lasSensorTurretTest :: RandomGen g => Int -> State g (LabSubCompTree Room)
lasSensorTurretTest n = do
cenroom <- shuffleLinks $ lightSensInsideDoor n cenLasTur
let doorroom = triggerDoorRoom n
return $ treeFromPost [PassDown door,PassDown cenroom,PassDown doorroom] (UseAll door)
return ( treeFromPost [PassDown door,PassDown cenroom,PassDown doorroom] (UseAll door)
, TreeSubLabelling "lasSensorTurretTest" Nothing
)
lasCenSensEdge :: RandomGen g => Int -> State g (SubCompTree Room)
lasCenSensEdge :: RandomGen g => Int -> State g (LabSubCompTree Room)
lasCenSensEdge n = do
cenroom <- shuffleLinks $ lightSensByDoor n cenLasTur
let doorroom = triggerDoorRoom n
return $ treeFromTrunk [PassDown door] $ Node (PassDown cenroom)
(return $ treeFromTrunk [PassDown door] $ Node (PassDown cenroom)
[ treeFromPost [PassDown doorroom] (UseAll door)
, treeFromPost [PassDown door] (UseLabel 0 corridor)
]
]) <&> (,TreeSubLabelling "lasCenSensEdge" Nothing)
lasTunnel :: RandomGen g => Float -> State g Room
lasTunnel y = do
@@ -183,12 +186,12 @@ lasTunnel y = do
]
-- a y value of 400 is probably "unrunnable"
lasTunnelRunPast :: RandomGen g => Float -> State g (SubCompTree Room)
lasTunnelRunPast :: RandomGen g => Float -> State g (LabSubCompTree Room)
lasTunnelRunPast y = do
r <- lasTunnel y
r1 <- takeOne [door,corridor]
r2 <- takeOne [door,corridor]
return $ Node (PassDown r)
(return $ Node (PassDown r)
[ singleUseAll r1
, return (UseLabel 0 $ r2 & rmConnectsTo .~ S.member InLink)
]
]) <&> (,TreeSubLabelling "lasTunnelRunPast" Nothing)
src/Dodge/Room/LongDoor.hs
+4 -4
View File
@@ -1,4 +1,4 @@
--{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TupleSections #-}
{- | Rooms containing long doors, probably with a big reveal behind them.
-}
module Dodge.Room.LongDoor where
@@ -142,10 +142,10 @@ slowDoorRoom = do
proom <- southPillarsRoom x y h
addButtonSlowDoor x h (proom & rmPmnts %~ (++ (crits ++ barrels)))
slowDoorRoomRunPast :: RandomGen g => State g (SubCompTree Room)
slowDoorRoomRunPast :: RandomGen g => State g (LabSubCompTree Room)
slowDoorRoomRunPast = do
r <- slowDoorRoom
return $ treeFromTrunk [PassDown door] $ Node (PassDown r)
(return $ treeFromTrunk [PassDown door] $ Node (PassDown r)
[ singleUseAll door
, return (UseLabel 0 $ door & rmConnectsTo .~ S.member InLink)
]
] ) <&> (,TreeSubLabelling "slowDoorRoomRunPast" Nothing)
src/Dodge/Room/LongRoom.hs
+4 -2
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE TupleSections #-}
module Dodge.Room.LongRoom where
import Dodge.RoomLink
import Dodge.Tree
@@ -48,10 +49,10 @@ longRoom = do
| crx <- [12.5,37.5,62.5] ] ++
[sPS (V2 25 lampy ) 0 putLamp | lampy <- [20,h-10] ]
longRoomRunPast :: RandomGen g => State g (SubCompTree Room)
longRoomRunPast :: RandomGen g => State g (LabSubCompTree Room)
longRoomRunPast = do
r <- longRoom
return $ treeFromTrunk [PassDown door]
(return $ treeFromTrunk [PassDown door]
(Node (PassDown r)
[ singleUseAll door
--, return (UseLabel 0 $ door & rmConnectsTo .~ S.singleton InLink)
@@ -60,3 +61,4 @@ longRoomRunPast = do
(UseLabel 0 door)
]
)
) <&> (,TreeSubLabelling "longRoomRunPast" Nothing)
src/Dodge/Room/Room.hs
+43 -22
View File
@@ -130,14 +130,18 @@ rot90Around cen p = cen +.+ vNormal (p -.- cen)
-- So, the idea is to attach outer children to the bottommost right nodes
-- inside an inner tree
roomMiniIntro :: RandomGen g => State g (SubCompTree Room)
roomMiniIntro :: RandomGen g => State g (LabSubCompTree Room)
roomMiniIntro = do
midroom <- join $ takeOne [miniTree2] --,glassLesson]
return $ chainUses [return $ UseAll corridor,return $ UseAll corridor,return $ UseAll corridor,return $ UseAll door, midroom,return $ UseAll corridor]
(return $ chainUses
[return $ UseAll corridor,return $ UseAll corridor,return $ UseAll corridor,return $ UseAll door, midroom,return $ UseAll corridor]
) <&> (,TreeSubLabelling "roomMiniIntro" Nothing)
roomCenterPillar :: RandomGen g => State g Room
roomCenterPillar = shuffleLinks . restrictInLinks ((\p -> dist p (V2 120 0) < 10) . fst)
$ set rmPmnts plmnts $ roomRect 240 240 2 2
$ set rmPmnts plmnts
$ set rmName "roomCenterPillar"
$ roomRect 240 240 2 2
where
plmnts =
[ blockLine (V2 115 115) (V2 115 125)
@@ -196,7 +200,7 @@ weaponEmptyRoom = do
$ restrictRMInLinksPD f (roomRect w h 2 2 & rmPmnts .~ plmnts)
return $ treeFromTrunk [PassDown corridor] (singleUseAll rm )
weaponUnderCrits :: RandomGen g => Int -> State g (SubCompTree Room)
weaponUnderCrits :: RandomGen g => Int -> State g (LabSubCompTree Room)
weaponUnderCrits i = do
let plmnts =
[--sPS (V2 20 0) 0 $ RandPS randFirstWeapon
@@ -204,23 +208,36 @@ weaponUnderCrits i = do
,sPS (V2 20 20) ( pi/2) randC1
]
addwpat p = rmPmnts .:~ PickOnePlacement i (sPS p 0 $ RandPS randFirstWeapon)
let continuationRoom = treeFromTrunk
let continuationRoom = treeFromTrunk
[PassDown $ addwpat (V2 20 0) corridorN,PassDown $ addwpat (V2 20 0) corridorN]
(singleUseAll (set rmPmnts plmnts corridorN))
rcp <- roomCenterPillar
rcp <- roomCenterPillar
rmpils <- roomPillars 30 240 240 2 2
deadEndRoom' <- takeOne
[ addwpat (V2 120 20) rmpils
, addwpat (V2 120 20) rcp]
junctionRoom <- takeOne [PassDown tEast,PassDown tWest]
return $ treeFromTrunk
--[PassDown $ corridorN & rmPmnts .:~ mntLightLnkCond (resetPLUse $ rprBool $ \rp _ -> isInLnk rp)
[PassDown corridorN
,PassDown corridorN]
$ Node junctionRoom
[continuationRoom
,singleUseNone deadEndRoom'
]
let thetree = treeFromTrunk
--[PassDown $ corridorN & rmPmnts .:~ mntLightLnkCond (resetPLUse $ rprBool $ \rp _ -> isInLnk rp)
[PassDown corridorN
,PassDown corridorN]
$ Node junctionRoom
[continuationRoom
,singleUseNone deadEndRoom'
]
return thetree
<&> (, TreeSubLabelling ("weaponUnderCrits "++show i) (Just $ fmap composingNodeName thetree))
composingNodeName :: ComposingNode Room -> TreeSubLabelling
composingNodeName cn = case cn of
PassDown rm -> f $ _rmName rm ++ "-PassDown"
SplitDown rm -> f $ _rmName rm ++ "-SplitDown"
UseAll rm -> f $ _rmName rm ++ "-UseAll"
UseSome is rm -> f $ _rmName rm ++ "-" ++ show is ++ "-UseSome"
UseNone rm -> f $ _rmName rm ++ "-UseNone"
UseLabel i rm -> f $ _rmName rm ++ "-" ++ show i ++ "-UseLabel"
where
f str = TreeSubLabelling str Nothing
weaponBehindPillar :: RandomGen g => State g (SubCompTree Room)
weaponBehindPillar = do
@@ -285,18 +302,21 @@ deadEndRoom = defaultRoom
, _rmPath = []
, _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 :: RandomGen g => Int -> State g (SubCompTree Room, String)
weaponRoom :: RandomGen g => Int -> State g (LabSubCompTree Room)
weaponRoom i = join $ takeOne
[ weaponEmptyRoom <&> (, "weaponEmptyRoom")
, weaponUnderCrits i<&> (, "weaponUnderCrits")
, weaponBehindPillar<&> (, "weaponBehindPillar")
, weaponBetweenPillars<&> (, "weaponBetweenPillars")
, weaponLongCorridor<&> (, "weaponLongCorridor")
[ weaponEmptyRoom <&> (,f "weaponEmptyRoom")
, weaponUnderCrits i
, weaponBehindPillar<&> (,f "weaponBehindPillar")
, weaponBetweenPillars<&> (,f "weaponBetweenPillars")
, weaponLongCorridor<&> (,f "weaponLongCorridor")
]
where
f str = TreeSubLabelling str Nothing
roomCCrits :: RandomGen g => State g Room
roomCCrits = roomC 200 200
@@ -392,7 +412,7 @@ pistolerRoom = pillarGrid
]
++)
shootingRange :: RandomGen g => State g (SubCompTree Room)
shootingRange :: RandomGen g => State g (LabSubCompTree Room)
shootingRange = do
rm1 <- shootersRoom1 >>= randomiseAllLinks . restrictInLinks (\(V2 _ y,_) -> y < 40)
. restrictOutLinks (\(V2 _ y,r) -> y > 200 && r /= 0)
@@ -402,7 +422,7 @@ shootingRange = do
rm3 <- shootersRoom >>= randomiseAllLinks
. restrictInLinks (\(V2 x y,_) -> y < 10 && x > 20 && x < 180)
. restrictOutLinks (\(_,r) -> r == 0)
return $ treeFromPost
(return $ treeFromPost
[PassDown rm1
,PassDown $ roomPadCut (rectNSWE 40 (-40) (-80) 80) (V2 0 20)
& rmPmnts %~ (spanLightI (V2 (-80) 10) (V2 80 10) :)
@@ -411,6 +431,7 @@ shootingRange = do
& rmPmnts %~ (spanLightI (V2 (-80) 10) (V2 80 10) :)
]
(UseAll rm3)
) <&> (,TreeSubLabelling "shootingRange" Nothing)
spawnerRoom :: RandomGen g => State g (SubCompTree Room)
spawnerRoom = do
src/Dodge/Room/SensorDoor.hs
+4 -3
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE TupleSections #-}
module Dodge.Room.SensorDoor where
import Dodge.LevelGen.Data
import Dodge.PlacementSpot
@@ -41,14 +42,14 @@ sensorRoom senseType n = do
let doorroom = triggerDoorRoom n
return $ treeFromPost [PassDown door,PassDown cenroom,PassDown doorroom] (UseAll door)
sensorRoomRunPast :: RandomGen g => DamageType -> Int -> State g (SubCompTree Room)
sensorRoomRunPast :: RandomGen g => DamageType -> Int -> State g (LabSubCompTree Room)
sensorRoomRunPast dt n = do
t <- sensorRoom dt n
return $ applyToSubforest [0] (++
(return $ applyToSubforest [0] (++
[treeFromPost [PassDown $ door & rmConnectsTo .~ S.member InLink
& rmName .~ "test"
] (UseLabel 0 corridor)]
) t
) t ) <&> (,TreeSubLabelling "sensorRoomRunPast" Nothing)
--[return $ UseLabel 0 $ door & rmConnectsTo .~ S.member InLink]
sensAboveDoor :: DamageType -> Float -> PlacementSpot -> Placement
src/Dodge/Room/Start.hs
+20 -18
View File
@@ -49,25 +49,27 @@ powerFakeout = do
,PassDown keyholeCorridor,PassDown corridor])
`treeFromPost` UseAll door
startRoom :: RandomGen g => Int -> State g (SubCompTree Room,String)
startRoom i = join $ uncurry takeOneWeighted $ unzip
startRoom :: RandomGen g => Int -> State g (LabSubCompTree Room)
startRoom i = (join $ uncurry takeOneWeighted $ unzip
[ (,) (0.5::Float) ((chainUses <$> sequence [powerFakeout,fmap fst $weaponRoom i])
<&> (,"chainUses <$> sequence [powerFakeout,weaponRoom i]"))
, (,) one (rezBoxesWp <&> (, "rezBoxesWp"))
<&> (,TreeSubLabelling "chainUses <$> sequence [powerFakeout,weaponRoom i]" Nothing))
, (,) one (rezBoxesWp <&> (,TreeSubLabelling "rezBoxesWp" Nothing))
, (,) one (rezBoxThenWeaponRoom i)
, (,) one (rezBoxesWpCrit <&> (,"rezBoxesWpCrit"))
, (,) one (runPastStart i <&> (,"runPastStart " ++ show i))
, (,) one (startCrafts >>= roomsContaining [] >>= rezBoxThenRooms <&>
(,"startCrafts >>= roomsContaining [] >>= rezBoxThenRooms"))
]
, (,) one (rezBoxesWpCrit <&> (,TreeSubLabelling "rezBoxesWpCrit" Nothing))
, (,) one (runPastStart i <&> (,TreeSubLabelling ("runPastStart " ++ show i) Nothing))
, (,) one (startCrafts >>= roomsContaining' [] >>= rezBoxThenRooms <&>
(,TreeSubLabelling "startCrafts >>= roomsContaining [] >>= rezBoxThenRooms" Nothing))
])
<&> over (_2 . topLabel) ("startRoom:"++)
where
roomsContaining' a b = fst <$> roomsContaining a b
one = 1::Float
randomChallenges :: RandomGen g => State g (SubCompTree Room)
randomChallenges = join $ takeOne
[fmap (return . UseAll) doubleCorridorBarrels
randomChallenges :: RandomGen g => State g (LabSubCompTree Room)
randomChallenges = join (takeOne
[fmap (return . UseAll) doubleCorridorBarrels <&> (,TreeSubLabelling "doubleCorridorBarrels" Nothing)
,shootingRange
,fmap (return . UseAll) twinSlowDoorChasers
]
,fmap (return . UseAll) twinSlowDoorChasers <&> (,TreeSubLabelling "twinSlowDoorChasers" Nothing)
]) <&> (over (_2 . topLabel) ("randomChallenges:"++))
runPastStart :: RandomGen g => Int -> State g (SubCompTree Room)
runPastStart i = do
@@ -83,15 +85,15 @@ rezBoxStart = do
rezBoxesThenWeaponRoom :: RandomGen g => Int -> State g (SubCompTree Room,String)
rezBoxesThenWeaponRoom i = do
rboxes <- rezBoxes
wroom <- fmap fst $ weaponRoom i
wroom <- fst <$> weaponRoom i
return (rboxes `passUntilUseAll` [wroom] , "rezBoxesThenWeaponRoom " ++ show i)
rezBoxThenWeaponRoom :: RandomGen g => Int -> State g (SubCompTree Room,String)
rezBoxThenWeaponRoom :: RandomGen g => Int -> State g (LabSubCompTree Room)
rezBoxThenWeaponRoom i = do
rcol <- rezColor
(wroom,wroomname) <- weaponRoom i
return $ (treeFromTrunk [PassDown $ rezBox rcol,PassDown door] wroom
, "rezBoxThenWeaponRoom "++ show i ++ ":" ++ wroomname)
return (treeFromTrunk [PassDown $ rezBox rcol,PassDown door] wroom
, TreeSubLabelling ("rezBoxThenWeaponRoom "++ show i) (Just $ return wroomname))
rezBoxThenRoom :: RandomGen g => Room -> State g (SubCompTree Room)
rezBoxThenRoom r = do
src/Dodge/Tree/Compose.hs
+1 -1
View File
@@ -35,7 +35,7 @@ overwriteLabel i f t ts = errorHead ("tried to overwriteLabel " ++ show i)
where
islabel (UseLabel j _) | i == j = True
islabel _ = False
update (Node cr _) = Node (f $ _unCompose cr) ts
update (Node x _) = Node (f $ _unCompose x) ts
passUntilUseAll :: SubCompTree a -> [SubCompTree a] -> SubCompTree a
passUntilUseAll (Node (UseAll x) _) ts' = Node (PassDown x) ts'
src/Dodge/Tree/Compose/Data.hs
+7
View File
@@ -12,4 +12,11 @@ data ComposingNode a
| UseLabel {_composeIndex :: Int, _unCompose :: a} -- defaults to using no children
type SubCompTree a = Tree (ComposingNode a)
type CompTree a = Tree (SubCompTree a)
type LabSubCompTree a = (Tree (ComposingNode a),TreeSubLabelling)
type LabCompTree a = Tree (LabSubCompTree a)
data TreeSubLabelling = TreeSubLabelling
{ _topLabel :: String
, _subLabels :: Maybe (Tree TreeSubLabelling)
}
makeLenses ''ComposingNode
makeLenses ''TreeSubLabelling