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

Commit mid big tree composing change

Browse Source
This commit is contained in:
justin
2022-06-09 21:25:22 +01:00
parent 8fb80f9691
commit 3edc7a0a58
20 changed files with 263 additions and 248 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Annotation.hs
+9 -9
View File
@@ -35,8 +35,8 @@ padSucWithDoors (Node x xs) = Node x (map (padWithAno [SpecificRoom thetree]) xs
thetree = do
thecor <- shuffleLinks corridor
takeOne
[ (return (UseAll door),TreeSubLabelling "door" Nothing)
, (treeFromPost [PassDown door, PassDown thecor] (UseAll door)
[ (return (useAll door),TreeSubLabelling "door" Nothing)
, (treeFromPost [ door, thecor] (useAll door)
,TreeSubLabelling "twoDoors" Nothing)
]
@@ -47,9 +47,9 @@ randomPadCorridors (Node x xs) = do
xs' <- mapM randomPadCorridors xs
return $ treeFromTrunk (replicate n [Corridor]) (Node x xs')
{- | Add a corridor to a random out-link of a room. -}
roomThenCorridor :: RandomGen g => Room -> State g (SubCompTree Room)
roomThenCorridor :: RandomGen g => Room -> State g (Tree Room)
roomThenCorridor theRoom = fmap
(\r -> Node (PassDown theRoom) [(pure . UseAll) r])
(\r -> Node ( theRoom) [(pure . useAll) r])
(shuffleLinks corridor)
{- | Create a random room tree structure from a list of annotations. -}
@@ -72,7 +72,7 @@ anoToRoomTree anos = case anos of
_ -> (,TreeSubLabelling "no label" Nothing) <$> anoToRoomTree' anos
{- | Create a random room tree structure from a list of annotations. -}
anoToRoomTree' :: [Annotation] -> State StdGen (SubCompTree Room)
anoToRoomTree' :: [Annotation] -> State StdGen (Tree Room)
anoToRoomTree' anos = case anos of
[ChainAnos ass] -> do
rms <- mapM anoToRoomTree' ass
@@ -80,12 +80,12 @@ anoToRoomTree' anos = case anos of
[OrAno as] -> do
a <- takeOne as
anoToRoomTree' a
[Corridor] -> pure . UseAll <$> shuffleLinks corridor
[Corridor] -> pure . useAll <$> shuffleLinks corridor
(BossAno cr : _) -> do
br <- bossRoom cr
branchRectWith . pure . fmap PassDown $ treeFromPost [corridor,corridor] br
(TreasureAno crs loot : _) -> branchRectWith . fmap (pure . PassDown) $ lootRoom crs loot
branchRectWith . pure . fmap $ treeFromPost [corridor,corridor] br
(TreasureAno crs loot : _) -> branchRectWith . fmap (pure . ) $ lootRoom crs loot
_ -> do
w <- state $ randomR (100,400)
h <- state $ randomR (200,400)
fmap (pure . UseAll) . shuffleLinks $ roomRectAutoLinks w h
fmap (pure . useAll) . shuffleLinks $ roomRectAutoLinks w h
src/Dodge/Annotation/Data.hs
+7 -6
View File
@@ -3,6 +3,7 @@
module Dodge.Annotation.Data where
import Dodge.Data
--import Dodge.Room
import TreeHelp
import Dodge.Tree.Compose.Data
import Control.Monad.State
@@ -14,16 +15,16 @@ data Annotation
| Corridor
| AirlockAno
| OrAno [[Annotation]]
| SpecificRoom (State StdGen (LabSubCompTree Room))
| SpecificRoom (State StdGen (LabTree Room))
| BossAno Creature
| TreasureAno [Creature] [Item]
| AnoApplyInt Int (Int -> State StdGen (LabSubCompTree Room))
| AnoNewInt (Int -> State StdGen (SubCompTree Room))
| AnoApplyInt Int (Int -> State StdGen (LabTree Room))
| AnoNewInt (Int -> State StdGen (Tree Room))
| PassthroughLockKeyLists Int
[(Int -> State StdGen (LabSubCompTree Room), State StdGen ItemBaseType)]
[(ItemBaseType, State StdGen (LabSubCompTree Room))]
[(Int -> State StdGen (LabTree Room), State StdGen ItemBaseType)]
[(ItemBaseType, State StdGen (LabTree Room))]
-- | SetLabel Int (State g Room)
-- | UseLabel Int (State g Room)
-- | useLabel Int (State g Room)
| ChainAnos [[Annotation]]
makeLenses ''Annotation
src/Dodge/Floor.hs
+14 -14
View File
@@ -39,7 +39,7 @@ initialAnoTree = padSucWithDoors $ treeFromPost
[[AnoApplyInt 0 startRoom]
, [PassthroughLockKeyLists 2 keyCardRunPastRand itemRooms]
, [SpecificRoom $ warningRooms 7]
, [SpecificRoom $ return (return . UseAll $ roomRectAutoLinks 400 400
, [SpecificRoom $ return (return . useAll $ roomRectAutoLinks 400 400
& rmPmnts .++~ [spNoID anyUnusedSpot (PutCrit invisibleChaseCrit)
, spNoID anyUnusedSpot (PutCrit armourChaseCrit)
]
@@ -48,33 +48,33 @@ initialAnoTree = padSucWithDoors $ treeFromPost
-- , [AnoApplyInt 100 healthTest]
, [PassthroughLockKeyLists 23
[(sensorRoomRunPast ELECTRICAL, takeOne [STATICMODULE,SPARKGUN] )] itemRooms]
, [SpecificRoom ((return . UseAll <$> tanksRoom [] [])
, [SpecificRoom ((return . useAll <$> tanksRoom [] [])
<&> (, TreeSubLabelling "empty tanksRoom" Nothing))]
, [PassthroughLockKeyLists 222 lockRoomKeyItems itemRooms]
, [SpecificRoom randomChallenges]
, [AnoApplyInt 1 lasSensorTurretTest]
-- ,[SpecificRoom $ fmap singleUseAll roomCCrits]
-- ,[SpecificRoom $ fmap pure roomCCrits]
-- ,[AirlockAno]
-- ,[Corridor]
------ ,[SpecificRoom roomCCrits]
------ ,[Corridor]
------ ,[SpecificRoom . pure . pure . UseAll $ roomGlassOctogon 400
------ ,[SpecificRoom . pure . pure . useAll $ roomGlassOctogon 400
------ & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit armourChaseCrit
------ ,sPS (V2 50 25) 0 $ PutCrit armourChaseCrit
------ ,sPS (V2 50 0) 0 $ PutCrit armourChaseCrit
------ ]++)
------ ]
------ --,[SpecificRoom . pure . pure . UseAll $ roomGlassOctogon 400
------ --,[SpecificRoom . pure . pure . useAll $ roomGlassOctogon 400
------ -- & rmPS %~ ([swarmPS 0 (x,y) 0 swarmCrit | x <- [-20,-19.5.. 20] , y <- [200,202] ]++)
------ -- ]
------ ,[SpecificRoom . pure . pure . UseAll $ roomGlassOctogon 400
------ ,[SpecificRoom . pure . pure . useAll $ roomGlassOctogon 400
------ & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit pistolCrit ]++)
------ ]
------ ,[Corridor]
---- --,[SpecificRoom $ pure . UseAll <$> twinSlowDoorChasers]
----- ,[SpecificRoom $ pure $ (pure . UseAll) (twinSlowDoorRoom 80 200 40)]
---- --,[SpecificRoom $ pure . useAll <$> twinSlowDoorChasers]
----- ,[SpecificRoom $ pure $ (pure . useAll) (twinSlowDoorRoom 80 200 40)]
----- ,[DoorAno]
----- ,[SpecificRoom $ pure . UseAll <$> centerVaultExplosiveExit]
----- ,[SpecificRoom $ pure . useAll <$> centerVaultExplosiveExit]
----- ,[SpecificRoom blockedCorridor]
----- ,[OrAno [[DoorAno]
----- ,[Corridor]
@@ -82,21 +82,21 @@ initialAnoTree = padSucWithDoors $ treeFromPost
----- ]
----- ,[FirstWeapon]
----- ,[CorridorDebug]
----- ,[SpecificRoom $ fmap (pure . UseAll) randomFourCornerRoom]
----- ,[SpecificRoom $ fmap (pure . useAll) randomFourCornerRoom]
-- ,[OrAno
-- [[SpecificRoom $ branchRectWith $ fmap (fmap PassDown) armouredChasers]
-- [[SpecificRoom $ branchRectWith $ fmap (fmap ) armouredChasers]
-- ,[BossAno $ addArmour launcherCrit & crHP +~ 800
-- & crState . crDropsOnDeath .~ DropSpecific [0] ]
-- ]
-- ]
---- ,[SpecificRoom $ fmap (pure . UseAll) armouredCorridor]
---- ,[SpecificRoom $ fmap (pure . useAll) armouredCorridor]
-- ,[Corridor]
-- ,[TreasureAno [addArmour autoCrit,addArmour autoCrit] [launcher]]
-- ,[Corridor]
,[SpecificRoom $ (pure . UseAll <$> randomFourCornerRoom [])
,[SpecificRoom $ (pure . useAll <$> randomFourCornerRoom [])
<&>(,TreeSubLabelling "randomFourCornerRoom" Nothing )]
]
[SpecificRoom $ fmap (pure . UseAll) (telRoomLev 1)
[SpecificRoom $ fmap (pure . useAll) (telRoomLev 1)
<&> (,TreeSubLabelling "telRoomLev" Nothing)]
{- | A test level tree. -}
src/Dodge/LockAndKey.hs
+10 -10
View File
@@ -13,12 +13,12 @@ import Dodge.Item
--import Dodge.Item.Equipment
bossKeyItems :: RandomGen g => [ (State g (SubCompTree Room), State g ItemBaseType) ]
bossKeyItems :: RandomGen g => [ (State g (Tree Room), State g ItemBaseType) ]
bossKeyItems =
[(return . UseAll <$> bossRoom autoCrit, takeOne [PISTOL])
[(return . useAll <$> bossRoom autoCrit, takeOne [PISTOL])
]
lockRoomMultiItems :: RandomGen g => [ ( State g (LabSubCompTree Room) , State g [ItemBaseType] ) ]
lockRoomMultiItems :: RandomGen g => [ ( State g (LabTree Room) , State g [ItemBaseType] ) ]
lockRoomMultiItems =
[ (blinkAcrossChallenge, takeOne [[BLINKERUNSAFE,AUTODETECTOR WALLDETECTOR]
,[BLINKERUNSAFE,CLICKDETECTOR WALLDETECTOR]
@@ -26,7 +26,7 @@ lockRoomMultiItems =
)
]
lockRoomKeyItems :: RandomGen g => [ (Int -> State g (LabSubCompTree Room) , State g ItemBaseType ) ]
lockRoomKeyItems :: RandomGen g => [ (Int -> State g (LabTree Room) , State g ItemBaseType ) ]
lockRoomKeyItems =
[(lasCenSensEdge, takeOne [LAUNCHER,LASGUN,SPARKGUN,FLATSHIELD,FORCEFIELDGUN] )
,(sensorRoomRunPast ELECTRICAL, takeOne [STATICMODULE,SPARKGUN] )
@@ -38,12 +38,12 @@ lockRoomKeyItems =
,(const $ lasTunnelRunPast 400, takeOne [FLATSHIELD,FORCEFIELDGUN])
,(keyCardRoomRunPast 0, return (KEYCARD 0))
]
keyCardRunPastRand :: RandomGen g => [ (Int -> State g (LabSubCompTree Room) , State g ItemBaseType ) ]
keyCardRunPastRand :: RandomGen g => [ (Int -> State g (LabTree Room) , State g ItemBaseType ) ]
keyCardRunPastRand =
[(keyCardRoomRunPast 0, return (KEYCARD 0))
]
itemRooms :: RandomGen g => [(ItemBaseType, State g (LabSubCompTree Room))]
itemRooms :: RandomGen g => [(ItemBaseType, State g (LabTree Room))]
itemRooms =
[ (LAUNCHER , join $ takeOne
[corridorBoss launcherCrit
@@ -104,17 +104,17 @@ someCrits = do
++ replicate 20 chaseCrit
--addcrits :: RandomGen g => [Item] -> State g (SubCompTree Room)
--addcrits :: RandomGen g => [Item] -> State g (Tree Room)
--addcrits its = do
-- nCrits <- state $ randomR (1,3)
-- crits <- takeN nCrits <=< shuffle $ fmap PutCrit $ [spreadGunCrit,pistolCrit,autoCrit,armourChaseCrit]
-- return $ roomsContaining crits its
corridorBoss :: RandomGen g => Creature -> State g (LabSubCompTree Room)
corridorBoss :: RandomGen g => Creature -> State g (LabTree Room)
corridorBoss cr = do
endroom <- bossRoom cr
return (treeFromPost (replicate 5 $ PassDown corridor)
(PassDown endroom)
return (treeFromPost (replicate 5 $ corridor)
( endroom)
,TreeSubLabelling ("corridorBoss-"++_crName cr) Nothing)
src/Dodge/Room/BlinkAcross.hs
+2 -2
View File
@@ -33,12 +33,12 @@ import LensHelp
import Control.Monad.State
import System.Random
blinkAcrossChallenge :: RandomGen g => State g (LabSubCompTree Room)
blinkAcrossChallenge :: RandomGen g => State g (LabTree Room)
blinkAcrossChallenge = do
teleFromRoom <- shuffleLinks $ roomRectAutoLinks 200 200
teleToRoom <- shuffleLinks $ roomRectAutoLinks 200 200
emptylink <- shuffleLinks emptyCorridor
return (treeFromPost [PassDown teleFromRoom,PassDown emptylink] (UseAll teleToRoom)
return (treeFromPost [ teleFromRoom, emptylink] (useAll teleToRoom)
, TreeSubLabelling "blinkAcrossChallenge" Nothing)
emptyCorridor :: Room
src/Dodge/Room/Branch.hs
+4 -4
View File
@@ -15,13 +15,13 @@ import Dodge.Tree
import Control.Monad.State
import System.Random
branchRectWith :: RandomGen g => State g (SubCompTree Room) -> State g (SubCompTree 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)
b <- t
rt <- shuffleLinks $ roomRectAutoLinks x y
return $ Node (PassDown rt)
[ Node (UseAll door) []
, changeToPassDown <$> treeFromTrunk [PassDown door] b
return $ Node ( rt)
[ Node (useAll door) []
, changeTo <$> treeFromTrunk [ door] b
]
src/Dodge/Room/Containing.hs
+1 -1
View File
@@ -15,7 +15,7 @@ import Geometry
import Data.List
roomsContaining :: RandomGen g => [Creature] -> [Item] -> State g (LabSubCompTree Room)
roomsContaining :: RandomGen g => [Creature] -> [Item] -> State g (LabTree Room)
roomsContaining crs its = do
endroom <- join $ takeOne
[ randomFourCornerRoomCrsIts crs its
src/Dodge/Room/GlassLesson.hs
+1 -1
View File
@@ -53,7 +53,7 @@ glassLesson = do
, mntLS vShape (V2 180 200) (V3 160 180 50)
]
]
glassLessonRunPast :: RandomGen g => State g (LabSubCompTree Room)
glassLessonRunPast :: RandomGen g => State g (LabTree Room)
glassLessonRunPast = (f <$> glassLesson) <&> (toOnward "glassLessonRunPast",)
where
f (Node r rs) = Node r $ return (useLabel 0 $ door & rmConnectsTo .~ S.member (OnEdge West)) : rs
src/Dodge/Room/LasTurret.hs
+27 -23
View File
@@ -1,6 +1,7 @@
--{-# LANGUAGE TupleSections #-}
module Dodge.Room.LasTurret where
import Dodge.LevelGen.Data
import Dodge.UseAll
import Dodge.PlacementSpot
import Dodge.Data
import Dodge.Tree
@@ -70,15 +71,15 @@ 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 (LabSubCompTree Room)
keyCardRoomRunPast :: RandomGen g => Int -> Int -> State g (LabTree Room)
keyCardRoomRunPast keyid rmid = do
cenroom <- shuffleLinks $ keyCardAnalyserByDoor keyid rmid $ roomNgon 6 200
let doorroom = triggerDoorRoom rmid
return (treeFromTrunk [PassDown door] $ Node (PassDown cenroom)
[ treeFromPost [PassDown doorroom] (UseAll door)
, treeFromPost [PassDown door] (UseLabel 0 corridor)
]
,TreeSubLabelling "keyCardRoomRunPast" Nothing)
return (toOnward "keyCardRoomRunPast",
treeFromTrunk [door] $ Node (cenroom)
[ treeFromPost [doorroom] (useAll door)
, treeFromPost [door] (useLabel 0 corridor)
])
keyCardAnalyserByDoor :: Int -> Int -> Room -> Room
keyCardAnalyserByDoor keyid = analyserByDoor (RequireEquipment (KEYCARD keyid))
@@ -102,31 +103,33 @@ analyserByDoor proxreq outplid rm = rm
where
sensorshift (p,a) = (p +.+ rotateV a (V2 30 (-10)), a)
healthTest :: RandomGen g => Int -> State g (SubCompTree Room)
healthTest :: RandomGen g => Int -> State g (Tree Room)
healthTest n = do
cenroom <- shuffleLinks $ healthAnalyserByDoor n $ roomNgon 8 200
let doorroom = triggerDoorRoom n
return $ treeFromPost [PassDown door
,PassDown $ corridor & rmPmnts .:~ spNoID (PS 20 0) (PutFlIt (medkit 100))
,PassDown cenroom,PassDown doorroom] (UseAll door)
return $ treeFromPost [door
, corridor & rmPmnts .:~ spNoID (PS 20 0) (PutFlIt (medkit 100))
, cenroom, doorroom]
(useAll door)
lasSensorTurretTest :: RandomGen g => Int -> State g (LabSubCompTree Room)
lasSensorTurretTest :: RandomGen g => Int -> State g (LabTree Room)
lasSensorTurretTest n = do
cenroom <- shuffleLinks $ lightSensInsideDoor n cenLasTur
let doorroom = triggerDoorRoom n
return ( treeFromPost [PassDown door,PassDown cenroom,PassDown doorroom] (UseAll door)
, TreeSubLabelling "lasSensorTurretTest" Nothing
return ( toOnward "lasSensorTurretTest"
, treeFromPost [ door, cenroom, doorroom] (useAll door)
)
lasCenSensEdge :: RandomGen g => Int -> State g (LabSubCompTree Room)
lasCenSensEdge :: RandomGen g => Int -> State g (LabTree Room)
lasCenSensEdge n = do
cenroom <- shuffleLinks $ lightSensByDoor n cenLasTur
let doorroom = triggerDoorRoom n
return (treeFromTrunk [PassDown door] $ Node (PassDown cenroom)
[ treeFromPost [PassDown doorroom] (UseAll door)
, treeFromPost [PassDown door] (UseLabel 0 corridor)
return (toOnward "lasCenSensEdge"
, treeFromTrunk [ door] $ Node ( cenroom)
[ treeFromPost [ doorroom] (useAll door)
, treeFromPost [ door] (useLabel 0 corridor)
]
,TreeSubLabelling "lasCenSensEdge" Nothing)
)
lasTunnel :: RandomGen g => Float -> State g Room
lasTunnel y = do
@@ -163,13 +166,14 @@ lasTunnel y = do
]
-- a y value of 400 is probably "unrunnable"
lasTunnelRunPast :: RandomGen g => Float -> State g (LabSubCompTree Room)
lasTunnelRunPast :: RandomGen g => Float -> State g (LabTree Room)
lasTunnelRunPast y = do
r <- lasTunnel y
r1 <- takeOne [door,corridor]
r2 <- takeOne [door,corridor]
return (Node (PassDown r)
[ singleUseAll r1
, return (UseLabel 0 $ r2 & rmConnectsTo .~ S.member InLink)
return (toOnward "lasTunnelRunPast"
, Node ( r)
[ pure $ useAll r1
, return (useLabel 0 $ r2 & rmConnectsTo .~ S.member InLink)
]
,TreeSubLabelling "lasTunnelRunPast" Nothing)
)
src/Dodge/Room/LongDoor.hs
+7 -5
View File
@@ -3,6 +3,7 @@
-}
module Dodge.Room.LongDoor where
import Dodge.Data
import Dodge.UseAll
import Dodge.RoomLink
import Dodge.Base
import Dodge.Tree
@@ -139,11 +140,12 @@ slowDoorRoom = do
proom <- southPillarsRoom x y h
addButtonSlowDoor x h (proom & rmPmnts %~ (++ (crits ++ barrels)))
slowDoorRoomRunPast :: RandomGen g => State g (LabSubCompTree Room)
slowDoorRoomRunPast :: RandomGen g => State g (LabTree Room)
slowDoorRoomRunPast = do
r <- slowDoorRoom
return (treeFromTrunk [PassDown door] $ Node (PassDown r)
[ singleUseAll door
, return (UseLabel 0 $ door & rmConnectsTo .~ S.member InLink)
return ( toOnward "slowDoorRoomRunPast"
, treeFromTrunk [ door] $ Node ( r)
[ pure $ useAll door
, return (useLabel 0 $ door & rmConnectsTo .~ S.member InLink)
]
,TreeSubLabelling "slowDoorRoomRunPast" Nothing)
)
src/Dodge/Room/LongRoom.hs
+9 -9
View File
@@ -1,5 +1,6 @@
--{-# LANGUAGE TupleSections #-}
module Dodge.Room.LongRoom where
import Dodge.UseAll
import Dodge.RoomLink
import Dodge.Tree
--import Dodge.Default.Room
@@ -46,16 +47,15 @@ longRoom = do
| crx <- [12.5,37.5,62.5] ] ++
[sPS (V2 25 lampy ) 0 putLamp | lampy <- [20,h-10] ]
longRoomRunPast :: RandomGen g => State g (LabSubCompTree Room)
longRoomRunPast :: RandomGen g => State g (LabTree Room)
longRoomRunPast = do
r <- longRoom
return (treeFromTrunk [PassDown door]
(Node (PassDown r)
[ singleUseAll door
--, return (UseLabel 0 $ door & rmConnectsTo .~ S.singleton InLink)
--, treeFromPost [PassDown $ corridor & rmConnectsTo .~ S.member InLink, PassDown corridor]
, treeFromPost [PassDown $ corridor & rmConnectsTo .~ S.member InLink]
(UseLabel 0 door)
return (toOnward "longRoomRunPast"
, treeFromTrunk [ door]
(Node ( r)
[ pure door
, treeFromPost [ corridor & rmConnectsTo .~ S.member InLink]
(useLabel 0 door)
]
)
,TreeSubLabelling "longRoomRunPast" Nothing)
)
src/Dodge/Room/RezBox.hs
+21 -19
View File
@@ -1,5 +1,6 @@
module Dodge.Room.RezBox where
import Dodge.LevelGen.Data
import Dodge.UseAll
--import Dodge.PlacementSpot
--import Dodge.Room.RunPast
import Dodge.RoomLink
@@ -39,7 +40,7 @@ rezBox ls = roomRect 40 60 1 1
& restrictOutLinks (\(V2 _ h,_)-> h > 59)
& rmName .~ "rezBox"
rezBoxesWp :: RandomGen g => State g (SubCompTree Room)
rezBoxesWp :: RandomGen g => State g (Tree Room)
rezBoxesWp = do
w <- state $ randomR (100,400)
h <- state $ randomR (40,40)
@@ -53,16 +54,17 @@ rezBoxesWp = do
let n = length $ getLinksOfType (OnEdge North) $ _rmLinks centralRoom
let rezrooms = map adddoor
$ wpAdd theweapon aroom : replicate (n-2) aroom
return $ treeFromTrunk [PassDown $ rezBox thecol
, PassDown door
return $ treeFromTrunk [ rezBox thecol
, door
]
(Node (PassDown centralRoom) (rezrooms ++ [onwardpassage]))
(Node ( centralRoom) (rezrooms ++ [onwardpassage]))
where
adddoor rm = treeFromPost [PassDown $ connectsToNorth door ] (PassDown rm)
adddoor rm = treeFromPost [ connectsToNorth door ] ( rm)
connectsToNorth = rmConnectsTo .~ S.member (OnEdge North)
maybeBlockedPassage :: RandomGen g => State g (SubCompTree Room)
maybeBlockedPassage = fmap singleUseAll $ join $ takeOne [return corridor, blockedCorridorCloseBlocks]
rezBoxesWpCrit :: RandomGen g => State g (SubCompTree Room)
maybeBlockedPassage :: RandomGen g => State g (Tree Room)
maybeBlockedPassage = fmap (pure . useAll)
$ join $ takeOne [return corridor, blockedCorridorCloseBlocks]
rezBoxesWpCrit :: RandomGen g => State g (Tree Room)
rezBoxesWpCrit = do
w <- state $ randomR (200,400)
h <- state $ randomR (40,40)
@@ -72,7 +74,7 @@ rezBoxesWpCrit = do
aroom = rezInvBox thecol
let centralRoom = (roomRectAutoLinks w h) {_rmPmnts = []}
onwardpassage <-
applyToCompRoot (rmConnectsTo .~ S.member (OnEdge West)) <$> maybeBlockedPassage
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)
@@ -80,31 +82,31 @@ rezBoxesWpCrit = do
$ insertAt i (wpAdd theweapon aroom)
$ insertAt j (crAdd aroom)
$ replicate (n-3) aroom
return $ treeFromTrunk [PassDown $ rezBox thecol
, PassDown door
return $ treeFromTrunk [ rezBox thecol
, door
]
(Node (PassDown centralRoom) (rezrooms ++ [onwardpassage]))
(Node ( centralRoom) (rezrooms ++ [onwardpassage]))
where
adddoor rm = treeFromPost [PassDown $ door & rmConnectsTo .~ S.member (OnEdge North)] (PassDown rm)
adddoor rm = treeFromPost [ door & rmConnectsTo .~ S.member (OnEdge North)] ( rm)
crAdd :: Room -> Room
crAdd = rmPmnts .:~ sPS (V2 20 10) (0.5*pi) randC1
rezBoxes :: RandomGen g => State g (SubCompTree Room)
rezBoxes :: RandomGen g => State g (Tree Room)
rezBoxes = do
w <- state $ randomR (100,400)
h <- state $ randomR (40,40)
thecol <- rezColor
let bottomEdgeTest = S.member (OnEdge South) . _rlType
dbox = treeFromPost [PassDown $ door & rmConnectsTo .~ S.member (OnEdge South)]
(PassDown $ rezInvBox thecol)
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 $ treeFromTrunk [PassDown $ rezBox thecol
, PassDown door
return $ treeFromTrunk [ rezBox thecol
, door
]
(Node (PassDown centralRoom) (replicate (n-1) dbox ++ [Node (UseAll door) []]))
(Node ( centralRoom) (replicate (n-1) dbox ++ [Node (useAll door) []]))
rezColor :: RandomGen g => State g LightSource
rezColor = do
src/Dodge/Room/RoadBlock.hs
+5 -4
View File
@@ -1,5 +1,6 @@
{- Connecting rooms designed with a pass-through technique in mind. -}
module Dodge.Room.RoadBlock where
import Dodge.UseAll
import Dodge.Data
import Dodge.RoomLink
import Geometry
@@ -50,18 +51,18 @@ litCorridor90 = do
}
-- | A random length corridor with a destructible block blocking it.
longBlockedCorridor :: RandomGen g => Int -> State g (SubCompTree Room)
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
]
sequence $ treeFromPost (replicate n $ PassDown <$> shuffleLinks corridor)
$ return $ UseAll $ set rmPmnts plmnts corridor
sequence $ treeFromPost (replicate n $ shuffleLinks corridor)
$ return $ useAll $ set rmPmnts plmnts corridor
-- | A single corridor with a destructible block blocking it.
blockedCorridor :: RandomGen g => State g (SubCompTree Room)
blockedCorridor :: RandomGen g => State g (Tree Room)
blockedCorridor = longBlockedCorridor 0
dirtPoly :: [Point2] -> PSType
src/Dodge/Room/Room.hs
+62 -60
View File
@@ -1,6 +1,7 @@
{-# LANGUAGE TupleSections #-}
module Dodge.Room.Room where
import Data.Tile
import Dodge.UseAll
import Dodge.Data
import Dodge.PlacementSpot
import Dodge.RoomLink
@@ -54,12 +55,12 @@ roomPadCut ps p = defaultRoom
, _rmPath = [(V2 0 0,p)]
}
branchWith :: Room -> [Tree Room] -> SubCompTree Room
branchWith r ts = Node (PassDown r) $ return (UseAll door) : fmap (fmap PassDown) ts
branchWith :: Room -> [Tree Room] -> Tree Room
branchWith r ts = Node r $ return (useAll door) : ts
manyDoors :: Int -> SubCompTree Room
manyDoors i = treeFromPost (replicate i (PassDown door)) $ UseAll door
manyDoors :: Int -> Tree Room
manyDoors i = treeFromPost (replicate i ( door)) $ useAll door
glassSwitchBack :: RandomGen g => State g Room
glassSwitchBack = do
@@ -96,12 +97,12 @@ glassSwitchBackCrits = glassSwitchBack
, spNoID (PSRoomRand 1 (uncurry PS)) randC1
] ++)
miniTree2 :: RandomGen g => State g (SubCompTree Room)
miniTree2 :: RandomGen g => State g (Tree Room)
miniTree2 = (glassSwitchBackCrits
>>= randomiseAllLinks . restrictInLinks (\p -> (sndV2 . fst) p < 70))
<&> flip branchWith (replicate 3 $ treeFromPost [door,corridor] critInDeadEnd)
miniRoom3 :: RandomGen g => State g (SubCompTree Room)
miniRoom3 :: RandomGen g => State g (Tree Room)
miniRoom3 = do
w <- state $ randomR (300,400)
h <- state $ randomR (300,400)
@@ -120,19 +121,19 @@ miniRoom3 = do
] ++
[ sPS cp 0 $ PutCrit miniGunCrit
, sPS (V2 (w/2) (h/2)) 0 putLamp ]
fmap singleUseAll $ shuffleLinks $ set rmPmnts plmnts $ roomRectAutoLinks w h
fmap (pure . useAll) $ shuffleLinks $ set rmPmnts plmnts $ roomRectAutoLinks w h
rot90Around :: Point2 -> Point2 -> Point2
rot90Around cen p = cen +.+ vNormal (p -.- cen)
-- So, the idea is to attach outer children to the bottommost right nodes
-- inside an inner tree
roomMiniIntro :: RandomGen g => State g (LabSubCompTree Room)
-- no idea what was going on here...
roomMiniIntro :: RandomGen g => State g (LabTree 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]
,TreeSubLabelling "roomMiniIntro" Nothing)
return ( toOnward "roomMiniIntro"
, midroom )
roomCenterPillar :: RandomGen g => State g Room
roomCenterPillar = shuffleLinks . restrictInLinks ((\p -> dist p (V2 120 0) < 10) . fst)
@@ -181,7 +182,7 @@ randFirstWeapon = do
++ replicate 5 (bangStick 4)
++ replicate 5 (bangCaneX 3)
weaponEmptyRoom :: RandomGen g => State g (SubCompTree Room)
weaponEmptyRoom :: RandomGen g => State g (Tree Room)
weaponEmptyRoom = do
w <- state $ randomR (220,300)
h <- state $ randomR (220,300)
@@ -195,9 +196,9 @@ weaponEmptyRoom = do
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 $ treeFromTrunk [PassDown corridor] (singleUseAll rm )
return $ treeFromTrunk [ corridor] (pure $ useAll rm )
weaponUnderCrits :: RandomGen g => Int -> State g (LabSubCompTree Room)
weaponUnderCrits :: RandomGen g => Int -> State g (LabTree Room)
weaponUnderCrits i = do
let plmnts =
[--sPS (V2 20 0) 0 $ RandPS randFirstWeapon
@@ -206,37 +207,37 @@ weaponUnderCrits i = do
]
addwpat p = rmPmnts .:~ PickOnePlacement i (sPS p 0 $ RandPS randFirstWeapon)
let continuationRoom = treeFromTrunk
[PassDown $ addwpat (V2 20 0) corridorN,PassDown $ addwpat (V2 20 0) corridorN]
(singleUseAll (set rmPmnts plmnts corridorN))
[ addwpat (V2 20 0) corridorN, addwpat (V2 20 0) corridorN]
(pure $ useAll (set rmPmnts plmnts corridorN))
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]
junctionRoom <- takeOne [ tEast, tWest]
let thetree = treeFromTrunk
--[PassDown $ corridorN & rmPmnts .:~ mntLightLnkCond (resetPLUse $ rprBool $ \rp _ -> isInLnk rp)
[PassDown corridorN
,PassDown corridorN]
--[ $ corridorN & rmPmnts .:~ mntLightLnkCond (resetPLUse $ rprBool $ \rp _ -> isInLnk rp)
[ corridorN
, corridorN]
$ Node junctionRoom
[continuationRoom
,singleUseNone deadEndRoom'
,pure deadEndRoom'
]
return thetree
<&> (, TreeSubLabelling ("weaponUnderCrits "++show i) (Just $ fmap composingNodeName thetree))
return (toOnward "weaponUnderCrits" , thetree )
-- TODO addSubmessages
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
--composingNodeName :: ComposingNode Room -> TreeSubLabelling
--composingNodeName cn = case cn of
-- rm -> f $ _rmName rm ++ "-"
-- 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 :: 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]
@@ -248,13 +249,13 @@ weaponBehindPillar = do
]
rcp <- roomCenterPillar
return $ treeFromTrunk
[PassDown corridor
--,PassDown $ over rmOutLinks tail $ over rmPmnts (++ plmnts1) rcp
,PassDown $ over rmPmnts (++ plmnts1) rcp
[ corridor
--, $ over rmOutLinks tail $ over rmPmnts (++ plmnts1) rcp
, over rmPmnts (++ plmnts1) rcp
]
(singleUseAll $ set rmPmnts [sPS (V2 20 60) (negate $ pi/2) randC1] corridorN)
(pure . useAll $ set rmPmnts [sPS (V2 20 60) (negate $ pi/2) randC1] corridorN)
weaponBetweenPillars :: RandomGen g => State g (SubCompTree Room)
weaponBetweenPillars :: RandomGen g => State g (Tree Room)
weaponBetweenPillars = do
(w,wn) <- takeOne [(240,2),(340,3)]
(h,hn) <- takeOne [(240,2),(340,3)]
@@ -271,9 +272,9 @@ weaponBetweenPillars = do
&& all ((>100) . dist (_rpPos rp)) (usedRoomLinkPoss r)
theRoom <- roomPillars 30 w h wn hn <&> rmPmnts .++~
sps wpPos (RandPS randFirstWeapon) : map (`sps` randC1) critPlacementSpots
return $ singleUseAll theRoom
return $ pure $ useAll theRoom
weaponLongCorridor :: RandomGen g => State g (SubCompTree Room)
weaponLongCorridor :: RandomGen g => State g (Tree Room)
weaponLongCorridor = do
rt <- takeOne [tEast, tWest]
connectingRoom <- takeOne
@@ -281,9 +282,9 @@ weaponLongCorridor = do
]
i1 <- state $ randomR (2,5)
i2 <- state $ randomR (2,5)
let branch1 = treeFromTrunk (replicate i1 $ PassDown corridorN) (singleUseAll $ putCrs connectingRoom)
let branch2 = treeFromTrunk (replicate i2 $ PassDown corridorN) (singleUseNone $ putWp corridor)
return $ Node (PassDown rt) [branch1,branch2]
let branch1 = treeFromTrunk (replicate i1 $ corridorN) (pure . useAll $ putCrs connectingRoom)
let branch2 = treeFromTrunk (replicate i2 $ corridorN) (pure . useSide $ putWp corridor)
return $ Node ( rt) [branch1,branch2]
where
putCrs = over rmPmnts (++ [sPS (V2 10 40) (-pi/2) randC1 ,sPS (V2 (-10) 40) (-pi/2) randC1 ])
putWp = set rmPmnts [sPS (V2 20 60) 0 $ RandPS randFirstWeapon ,spanLightI (V2 0 40) (V2 40 40)]
@@ -304,16 +305,16 @@ deadEndRoom = defaultRoom
where
lnks = [(V2 0 30 ,0) ]
{- A random Either tree with a weapon and melee monster challenge. -}
weaponRoom :: RandomGen g => Int -> State g (LabSubCompTree Room)
weaponRoom :: RandomGen g => Int -> State g (LabTree Room)
weaponRoom i = join $ takeOne
[ weaponEmptyRoom <&> (,f "weaponEmptyRoom")
[ weaponEmptyRoom <&> (f "weaponEmptyRoom")
, weaponUnderCrits i
, weaponBehindPillar<&> (,f "weaponBehindPillar")
, weaponBetweenPillars<&> (,f "weaponBetweenPillars")
, weaponLongCorridor<&> (,f "weaponLongCorridor")
, weaponBehindPillar<&> (f "weaponBehindPillar")
, weaponBetweenPillars<&> (f "weaponBetweenPillars")
, weaponLongCorridor<&> (f "weaponLongCorridor")
]
where
f str = TreeSubLabelling str Nothing
f str = ( toOnward str ,)
roomCCrits :: RandomGen g => State g Room
roomCCrits = roomC 200 200
@@ -409,7 +410,7 @@ pistolerRoom = pillarGrid
]
++)
shootingRange :: RandomGen g => State g (LabSubCompTree Room)
shootingRange :: RandomGen g => State g (LabTree Room)
shootingRange = do
rm1 <- shootersRoom1 >>= randomiseAllLinks . restrictInLinks (\(V2 _ y,_) -> y < 40)
. restrictOutLinks (\(V2 _ y,r) -> y > 200 && r /= 0)
@@ -419,22 +420,23 @@ shootingRange = do
rm3 <- shootersRoom >>= randomiseAllLinks
. restrictInLinks (\(V2 x y,_) -> y < 10 && x > 20 && x < 180)
. restrictOutLinks (\(_,r) -> r == 0)
return (treeFromPost
[PassDown rm1
,PassDown $ roomPadCut (rectNSWE 40 (-40) (-80) 80) (V2 0 20)
return ( toOnward "shootingRange"
,treeFromPost
[ rm1
, roomPadCut (rectNSWE 40 (-40) (-80) 80) (V2 0 20)
& rmPmnts %~ (spanLightI (V2 (-80) 10) (V2 80 10) :)
,PassDown rm2
,PassDown $ roomPadCut (rectNSWE 40 (-40) (-80) 80) (V2 0 20)
, rm2
, roomPadCut (rectNSWE 40 (-40) (-80) 80) (V2 0 20)
& rmPmnts %~ (spanLightI (V2 (-80) 10) (V2 80 10) :)
]
(UseAll rm3)
,TreeSubLabelling "shootingRange" Nothing)
(useAll rm3)
)
spawnerRoom :: RandomGen g => State g (SubCompTree Room)
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 (PSRoomRand 0 (uncurry PS)) (PutCrit spawnerCrit) :)
aRoom <- airlock
return $ treeFromTrunk [PassDown aRoom,PassDown corridor] $ singleUseAll roomWithSpawner
return $ treeFromTrunk [ aRoom, corridor] $ pure $ useAll roomWithSpawner
src/Dodge/Room/RunPast.hs
+9 -8
View File
@@ -1,4 +1,5 @@
module Dodge.Room.RunPast where
import Dodge.UseAll
import Dodge.LevelGen.Data
import Dodge.LightSource
import Dodge.RoomLink
@@ -41,7 +42,7 @@ roomCritLS = do
critRoom :: Room
critRoom = corridorWallN & rmRandPSs .~ [psRandRanges (15,25) (30,45) (pi,2*pi)]
runPastRoom :: RandomGen g => Int -> State g (SubCompTree Room)
runPastRoom :: RandomGen g => Int -> State g (Tree Room)
runPastRoom i = do
h <- state $ randomR (200,400::Float)
theedgetest <- takeOne [horEdgeTest (<1), horEdgeTest (>39)]
@@ -59,10 +60,10 @@ runPastRoom i = do
}
switchdoor = triggerDoorRoom i
n = length $ filter theedgetest $ map lnkPosDir $ _rmLinks cenroom
controom = treeFromPost [PassDown switchdoor,PassDown linkcor] (UseAll door)
critrooms :: [SubCompTree Room]
critrooms = treeFromPost [PassDown switchdoor] (PassDown critroom) :
replicate (n-2) (treeFromPost [PassDown switchdoor] (PassDown linkcor))
return $ Node (PassDown cenroom) $
map (applyToCompRoot $ rmConnectsTo .~ S.member (OnEdge theedge)) (controom : critrooms)
++ [return $ PassDown aswitchroom]
controom = treeFromPost [ switchdoor, linkcor] (useAll door)
critrooms :: [Tree Room]
critrooms = treeFromPost [ switchdoor] ( critroom) :
replicate (n-2) (treeFromPost [ switchdoor] ( linkcor))
return $ Node ( cenroom) $
map (over root $ rmConnectsTo .~ S.member (OnEdge theedge)) (controom : critrooms)
++ [return $ aswitchroom]
src/Dodge/Room/SensorDoor.hs
+9 -8
View File
@@ -1,5 +1,6 @@
--{-# LANGUAGE TupleSections #-}
module Dodge.Room.SensorDoor where
import Dodge.UseAll
import Dodge.LevelGen.Data
import Dodge.PlacementSpot
import Dodge.Placement.Instance.Terminal
@@ -35,12 +36,12 @@ import Data.Maybe
-- 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 (SubCompTree Room)
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
let doorroom = triggerDoorRoom n
return $ treeFromPost [PassDown door,PassDown $ cenroom & rmLinkEff .~ f,PassDown doorroom] (UseAll door)
return $ treeFromPost [ door, cenroom & rmLinkEff .~ f, doorroom] (useAll door)
where
f _ _ 0 rl rm = rm & rmLinks %~ map (g (_rlPos rl) (_rlDir rl))
f _ _ _ _ rm = rm
@@ -51,18 +52,18 @@ sensorRoom senseType n = do
p' = p +.+ rotateV d (V2 0 (negate 100))
isclose = dist (_rlPos rl) p' < 30
sensorRoomRunPast :: RandomGen g => DamageType -> Int -> State g (LabSubCompTree Room)
sensorRoomRunPast :: RandomGen g => DamageType -> Int -> State g (LabTree Room)
sensorRoomRunPast dt n = do
t <- sensorRoom dt n
return (applyToSubforest [0] (++
return ( toOnward "sensorRoomRunPast"
, applyToSubforest [0] (++
[treeFromPost
[PassDown $ door & rmConnectsTo
[ door & rmConnectsTo
.~ (\s -> S.member InLink s && not (S.member BlockedLink s))
] (UseLabel 0 corridor)
] (useLabel 0 corridor)
]
) t
,TreeSubLabelling "sensorRoomRunPast" Nothing)
--[return $ UseLabel 0 $ door & rmConnectsTo .~ S.member InLink]
)--[return $ useLabel 0 $ door & rmConnectsTo .~ S.member InLink]
sensAboveDoor :: DamageType -> Float -> PlacementSpot -> Placement
sensAboveDoor sensetype wth ps = extTrigLitPos
src/Dodge/Room/Start.hs
+32 -30
View File
@@ -1,5 +1,6 @@
{-# LANGUAGE TupleSections #-}
module Dodge.Room.Start where
import Dodge.UseAll
import Dodge.Data
import Dodge.LevelGen.Data
--import Dodge.PlacementSpot
@@ -29,7 +30,7 @@ import LensHelp
--import Data.Tree
--import qualified Data.IntMap.Strict as IM
powerFakeout :: RandomGen g => State g (SubCompTree Room)
powerFakeout :: RandomGen g => State g (Tree Room)
powerFakeout = do
ncor <- state $ randomR (0,2)
it <- takeOne
@@ -37,71 +38,72 @@ powerFakeout = do
,launcherX 7
]
roomwithmini <- pedestalRoom it
randcors <- replicateM ncor $ (fmap PassDown . shuffleLinks) corridor
return $ ([PassDown door
,PassDown roomwithmini
,PassDown door
randcors <- replicateM ncor $ shuffleLinks corridor
return $ ([ door
, roomwithmini
, door
]
++ randcors
++ [PassDown $ corridor & rmPmnts .:~ plRRpt 0 (PutFlIt shrinkGun)
,PassDown keyholeCorridor,PassDown corridor])
`treeFromPost` UseAll door
++ [ corridor & rmPmnts .:~ plRRpt 0 (PutFlIt shrinkGun)
, keyholeCorridor, corridor])
`treeFromPost` useAll door
startRoom :: RandomGen g => Int -> State g (LabSubCompTree Room)
startRoom :: RandomGen g => Int -> State g (LabTree Room)
startRoom i = join (uncurry takeOneWeighted $ unzip
[ (,) (0.5::Float) ((chainUses <$> sequence [powerFakeout,fmap fst $weaponRoom i])
<&> (,TreeSubLabelling "chainUses <$> sequence [powerFakeout,weaponRoom i]" Nothing))
, (,) one (rezBoxesWp <&> (,TreeSubLabelling "rezBoxesWp" Nothing))
[-- (,) (0.5::Float) ((chainUses <$> sequence [powerFakeout,fmap fst $weaponRoom i])
-- <&> (,TreeSubLabelling "chainUses <$> sequence [powerFakeout,weaponRoom i]" Nothing))
-- wat
(,) one (rezBoxesWp <&> (toOnward "rezBoxesWp",))
, (,) one (rezBoxThenWeaponRoom i)
, (,) one (rezBoxesWpCrit <&> (,TreeSubLabelling "rezBoxesWpCrit" Nothing))
, (,) one (runPastStart i <&> (,TreeSubLabelling ("runPastStart " ++ show i) Nothing))
, (,) one (rezBoxesWpCrit <&> (toOnward "rezBoxesWpCrit"))
, (,) one (runPastStart i <&> (toOnward ("runPastStart " ++ show i)))
, (,) one (startCrafts >>= roomsContaining' [] >>= rezBoxThenRooms <&>
(,TreeSubLabelling "startCrafts >>= roomsContaining [] >>= rezBoxThenRooms" Nothing))
(toOnward "startCrafts >>= roomsContaining [] >>= rezBoxThenRooms"))
])
<&> over (_2 . topLabel) ("startRoom:"++)
where
roomsContaining' a b = fst <$> roomsContaining a b
one = 1::Float
randomChallenges :: RandomGen g => State g (LabSubCompTree Room)
randomChallenges :: RandomGen g => State g (LabTree Room)
randomChallenges = join (takeOne
[fmap (return . UseAll) doubleCorridorBarrels <&> (,TreeSubLabelling "doubleCorridorBarrels" Nothing)
[fmap (return . useAll) doubleCorridorBarrels <&> (,TreeSubLabelling "doubleCorridorBarrels" Nothing)
,shootingRange
,fmap (return . UseAll) twinSlowDoorChasers <&> (,TreeSubLabelling "twinSlowDoorChasers" Nothing)
,fmap (return . useAll) twinSlowDoorChasers <&> (,TreeSubLabelling "twinSlowDoorChasers" Nothing)
]) <&> over (_2 . topLabel) ("randomChallenges:"++)
runPastStart :: RandomGen g => Int -> State g (SubCompTree Room)
runPastStart :: RandomGen g => Int -> State g (Tree Room)
runPastStart i = do
s <- rezBoxStart
rp <- runPastRoom i
return $ s `passUntilUseAll` [rp]
return $ s `passUntiluseAll` [rp]
rezBoxStart :: RandomGen g => State g (SubCompTree Room)
rezBoxStart :: RandomGen g => State g (Tree Room)
rezBoxStart = do
ls <- rezColor
return $ treeFromPost [PassDown $ rezBox ls] (UseAll door)
return $ treeFromPost [ rezBox ls] (useAll door)
rezBoxesThenWeaponRoom :: RandomGen g => Int -> State g (SubCompTree Room,String)
rezBoxesThenWeaponRoom :: RandomGen g => Int -> State g (Tree Room,String)
rezBoxesThenWeaponRoom i = do
rboxes <- rezBoxes
wroom <- fst <$> weaponRoom i
return (rboxes `passUntilUseAll` [wroom] , "rezBoxesThenWeaponRoom " ++ show i)
return (rboxes `passUntiluseAll` [wroom] , "rezBoxesThenWeaponRoom " ++ show i)
rezBoxThenWeaponRoom :: RandomGen g => Int -> State g (LabSubCompTree Room)
rezBoxThenWeaponRoom :: RandomGen g => Int -> State g (LabTree Room)
rezBoxThenWeaponRoom i = do
rcol <- rezColor
(wroom,wroomname) <- weaponRoom i
return (treeFromTrunk [PassDown $ rezBox rcol,PassDown door] wroom
return (treeFromTrunk [ rezBox rcol, door] wroom
, TreeSubLabelling ("rezBoxThenWeaponRoom "++ show i) (Just $ return wroomname))
rezBoxThenRoom :: RandomGen g => Room -> State g (SubCompTree Room)
rezBoxThenRoom :: RandomGen g => Room -> State g (Tree Room)
rezBoxThenRoom r = do
rcol <- rezColor
return $ treeFromTrunk [PassDown $ rezBox rcol,PassDown door] $ singleUseAll r
return $ treeFromTrunk [ rezBox rcol, door] $ pure r
rezBoxThenRooms :: RandomGen g => SubCompTree Room -> State g (SubCompTree Room)
rezBoxThenRooms :: RandomGen g => Tree Room -> State g (Tree Room)
rezBoxThenRooms r = do
rcol <- rezColor
return . treeFromTrunk [PassDown $ rezBox rcol,PassDown door] $ r
return . treeFromTrunk [ rezBox rcol, door] $ r
startCrafts :: RandomGen g => State g [Item]
startCrafts = takeOne $ map (map makeTypeCraft)
src/Dodge/Room/Warning.hs
+4 -3
View File
@@ -36,13 +36,14 @@ import qualified Data.Map.Strict as M
--import qualified Data.Text as T
warningRooms :: RandomGen g => Int -> State g (LabSubCompTree Room)
warningRooms :: RandomGen g => Int -> State g (LabTree Room)
warningRooms n = do
rm <- takeOne [roomNgon 8 200, roomRectAutoLinks 200 200]
cenroom <- shuffleLinks $ addWarningTerminal n rm
let doorroom = triggerDoorRoom n
return ( treeFromPost [PassDown door,PassDown cenroom,PassDown doorroom] (UseAll door)
, TreeSubLabelling "warningRooms" Nothing)
return ( toOnward "warningRooms"
, treeFromPost [ door, cenroom, doorroom] (useAll door)
)
addWarningTerminal :: Int -> Room -> Room
addWarningTerminal outplid = (rmName .++~ "warningTerm-")
src/Dodge/Tree/Compose.hs
+25 -25
View File
@@ -2,12 +2,12 @@
{-| Combining and composing trees of trees. -}
module Dodge.Tree.Compose
( --expandTree
--, singleUseAll
--, singleUseNone
--, passUntilUseAll
--, pure
--, pure
--, passUntiluseAll
--, chainUses
--, useAllAtEnd
--, changeToPassDown
--, changeTo
--, overwriteLabel
--, applyToCompRoot
composeTree
@@ -28,47 +28,47 @@ import Data.Maybe
--expandTree :: CompTree a -> Tree a
--expandTree (Node rt extChildren) = case rt of
-- Node (UseAll x) _ -> Node x (map expandTree extChildren)
-- Node (useAll x) _ -> Node x (map expandTree extChildren)
-- Node (UseSome is x) _ -> Node x (map (expandTree . \i -> extChildren !! i) is)
-- Node (UseNone _) _ -> fmap _unCompose rt
-- Node (UseLabel _ _) _ -> fmap _unCompose rt
-- Node (PassDown x) xs -> Node x $ map (expandTree . (`Node` extChildren)) xs
-- Node (useLabel _ _) _ -> fmap _unCompose rt
-- Node ( x) xs -> Node x $ map (expandTree . (`Node` extChildren)) xs
-- Node (SplitDown x) xs -> Node x $ map expandTree $ zipWith Node xs
-- $ map (:[]) extChildren ++ repeat []
--applyToCompRoot :: (a -> a) -> SubCompTree a -> SubCompTree a
--applyToCompRoot :: (a -> a) -> Tree a -> Tree a
--applyToCompRoot f = over root (unCompose %~ f)
--overwriteLabel :: Int -> (a -> ComposingNode a) -> SubCompTree a -> [SubCompTree a] -> SubCompTree a
--overwriteLabel :: Int -> (a -> ComposingNode a) -> Tree a -> [Tree a] -> Tree a
--overwriteLabel i f t ts = errorHead ("tried to overwriteLabel " ++ show i)
-- $ updateSingleNodes islabel update t
-- where
-- islabel (UseLabel j _) | i == j = True
-- islabel (useLabel j _) | i == j = True
-- islabel _ = False
-- update (Node x _) = Node (f $ _unCompose x) ts
--passUntilUseAll :: SubCompTree a -> [SubCompTree a] -> SubCompTree a
--passUntilUseAll (Node (UseAll x) _) ts' = Node (PassDown x) ts'
--passUntilUseAll (Node cn ts) ts' = Node (PassDown (_unCompose cn)) $ map (`passUntilUseAll` ts') ts
--passUntiluseAll :: Tree a -> [Tree a] -> Tree a
--passUntiluseAll (Node (useAll x) _) ts' = Node ( x) ts'
--passUntiluseAll (Node cn ts) ts' = Node ( (_unCompose cn)) $ map (`passUntiluseAll` ts') ts
--chainUses :: [SubCompTree a] -> SubCompTree a
--chainUses (t:s:ts) = chainUses (passUntilUseAll t [s]:ts)
--chainUses :: [Tree a] -> Tree a
--chainUses (t:s:ts) = chainUses (passUntiluseAll t [s]:ts)
--chainUses [t] = t
--chainUses [] = error "tried to concatenate an empty list of SubCompTrees"
--chainUses [] = error "tried to concatenate an empty list of Trees"
--singleUseAll :: a -> Tree (ComposingNode a)
--singleUseAll x = Node (UseAll x) []
--pure :: a -> Tree (ComposingNode a)
--pure x = Node (useAll x) []
--useAllAtEnd :: Tree a -> SubCompTree a
--useAllAtEnd :: Tree a -> Tree a
--useAllAtEnd tree = case tree of
-- Node x (t:ts) -> Node (PassDown x) (useAllAtEnd t : map (fmap UseNone) ts)
-- Node x [] -> Node (UseAll x) []
-- Node x (t:ts) -> Node ( x) (useAllAtEnd t : map (fmap UseNone) ts)
-- Node x [] -> Node (useAll x) []
--singleUseNone :: a -> SubCompTree a
--singleUseNone x = Node (UseNone x) []
--pure :: a -> Tree a
--pure x = Node (UseNone x) []
--changeToPassDown :: ComposingNode a -> ComposingNode a
--changeToPassDown x = PassDown (_unCompose x)
--changeTo :: ComposingNode a -> ComposingNode a
--changeTo x = (_unCompose x)
composeTreeRand :: RandomGen g => Tree (a -> Maybe a, Tree a) -> State g (Tree a)
composeTreeRand (Node (_,t) ts) = attachListR t ts
src/Dodge/Tree/Compose/Data.hs
+5 -7
View File
@@ -4,16 +4,14 @@ module Dodge.Tree.Compose.Data where
import Data.Tree
import Control.Lens
data ComposingNode a
= PassDown {_unCompose :: a}
| SplitDown {_unCompose :: a}
| UseAll {_unCompose :: a}
= SplitDown {_unCompose :: a}
-- | useAll {_unCompose :: a}
| UseSome {_composeIndices :: [Int], _unCompose :: a}
| UseNone {_unCompose :: a}
| UseLabel {_composeIndex :: Int, _unCompose :: a} -- defaults to using no children
type SubCompTree a = Tree a
-- | useLabel {_composeIndex :: Int, _unCompose :: a} -- defaults to using no children
type CompTree a = Tree (Tree a)
type LabSubCompTree a = (a -> Maybe ([String],a),Tree a)
type LabCompTree a = Tree (LabSubCompTree a)
type LabTree a = (a -> Maybe ([String],a),Tree a)
type LabCompTree a = Tree (LabTree a)
data TreeSubLabelling = TreeSubLabelling
{ _topLabel :: String
, _subLabels :: Maybe (Tree TreeSubLabelling)