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

Redo tree composition

Browse Source
This commit is contained in:
justin
2022-06-10 00:08:32 +01:00
parent 3edc7a0a58
commit 5532c25d3c
13 changed files with 114 additions and 52 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Annotation.hs
+12 -14
View File
@@ -4,6 +4,7 @@ module Dodge.Annotation
( module Dodge.Annotation.Data
, module Dodge.Annotation
) where
import Dodge.UseAll
import RandomHelp
import Dodge.Tree
import Dodge.Room
@@ -35,9 +36,10 @@ padSucWithDoors (Node x xs) = Node x (map (padWithAno [SpecificRoom thetree]) xs
thetree = do
thecor <- shuffleLinks corridor
takeOne
[ (return (useAll door),TreeSubLabelling "door" Nothing)
, (treeFromPost [ door, thecor] (useAll door)
,TreeSubLabelling "twoDoors" Nothing)
[ (toOnward "door", return (useAll door))
, (toOnward "twoDoors"
,treeFromPost [ door, thecor] (useAll door)
)
]
{- Add one to three corridors between each parent-child link of a tree of annotations. -}
@@ -62,29 +64,25 @@ anoToRoomTree anos = case anos of
(functionlockroom,randomitemidentity) <- takeOne ls
lr' <- functionlockroom i
ii <- randomitemidentity
let lr = fst lr'
let lr = snd 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'))
let keyroom = snd keyroom'
return (toOnward ("PassthroughLockKeyLists-"++show ii)
, overwriteLabel 0 lr [keyroom]
)
_ -> (,TreeSubLabelling "no label" Nothing) <$> anoToRoomTree' anos
_ -> (toOnward "no label" ,) <$> anoToRoomTree' anos
{- | Create a random room tree structure from a list of annotations. -}
anoToRoomTree' :: [Annotation] -> State StdGen (Tree Room)
anoToRoomTree' anos = case anos of
[ChainAnos ass] -> do
rms <- mapM anoToRoomTree' ass
return $ chainUses rms
[OrAno as] -> do
a <- takeOne as
anoToRoomTree' a
[Corridor] -> pure . useAll <$> shuffleLinks corridor
(BossAno cr : _) -> do
br <- bossRoom cr
branchRectWith . pure . fmap $ treeFromPost [corridor,corridor] br
(TreasureAno crs loot : _) -> branchRectWith . fmap (pure . ) $ lootRoom crs loot
branchRectWith . pure $ treeFromPost [corridor,corridor] br
(TreasureAno crs loot : _) -> branchRectWith . fmap pure $ lootRoom crs loot
_ -> do
w <- state $ randomR (100,400)
h <- state $ randomR (200,400)
src/Dodge/Annotation/Data.hs
-1
View File
@@ -25,6 +25,5 @@ data Annotation
[(ItemBaseType, State StdGen (LabTree Room))]
-- | SetLabel Int (State g Room)
-- | useLabel Int (State g Room)
| ChainAnos [[Annotation]]
makeLenses ''Annotation
src/Dodge/Floor.hs
+9 -7
View File
@@ -4,6 +4,7 @@
module Dodge.Floor
( initialRoomTree
) where
import Dodge.UseAll
--import Geometry.Data
--import Dodge.Data
import Dodge.LockAndKey
@@ -39,17 +40,18 @@ initialAnoTree = padSucWithDoors $ treeFromPost
[[AnoApplyInt 0 startRoom]
, [PassthroughLockKeyLists 2 keyCardRunPastRand itemRooms]
, [SpecificRoom $ warningRooms 7]
, [SpecificRoom $ return (return . useAll $ roomRectAutoLinks 400 400
& rmPmnts .++~ [spNoID anyUnusedSpot (PutCrit invisibleChaseCrit)
, [SpecificRoom $ return ( toOnward "chaseCrit+armourChaseCrit rectRoom"
, return . useAll $ roomRectAutoLinks 400 400
& rmPmnts .++~ [spNoID anyUnusedSpot (PutCrit invisibleChaseCrit)
, spNoID anyUnusedSpot (PutCrit armourChaseCrit)
]
, TreeSubLabelling "chaseCrit+armourChaseCrit rectRoom" Nothing)
)
]
-- , [AnoApplyInt 100 healthTest]
, [PassthroughLockKeyLists 23
[(sensorRoomRunPast ELECTRICAL, takeOne [STATICMODULE,SPARKGUN] )] itemRooms]
, [SpecificRoom ((return . useAll <$> tanksRoom [] [])
<&> (, TreeSubLabelling "empty tanksRoom" Nothing))]
<&> (toOnward "empty tanksRoom",))]
, [PassthroughLockKeyLists 222 lockRoomKeyItems itemRooms]
, [SpecificRoom randomChallenges]
, [AnoApplyInt 1 lasSensorTurretTest]
@@ -94,11 +96,11 @@ initialAnoTree = padSucWithDoors $ treeFromPost
-- ,[TreasureAno [addArmour autoCrit,addArmour autoCrit] [launcher]]
-- ,[Corridor]
,[SpecificRoom $ (pure . useAll <$> randomFourCornerRoom [])
<&>(,TreeSubLabelling "randomFourCornerRoom" Nothing )]
<&>(toOnward "randomFourCornerRoom" , )]
]
[SpecificRoom $ fmap (pure . useAll) (telRoomLev 1)
<&> (,TreeSubLabelling "telRoomLev" Nothing)]
<&> (toOnward "telRoomLev" ,)]
{- | A test level tree. -}
initialRoomTree :: State StdGen (Tree (Room -> Maybe (String,Room), Tree Room))
initialRoomTree :: State StdGen (Tree (Room -> Maybe ([String],Room), Tree Room))
initialRoomTree = mapM anoToRoomTree initialAnoTree
src/Dodge/LevelGen.hs
+6 -3
View File
@@ -32,9 +32,12 @@ layoutLevelFromSeed i seed = do
appendFile "attemptedSeeds" $ show seed ++ "\n"
let g = mkStdGen seed
let treecluster = evalState initialRoomTree g
putStrLn "Room cluster layout:"
putStrLn $ drawTreeSubLabelling $ fmap snd treecluster
let rmtree = inorderNumberTree $ expandTree $ fmap fst treecluster
(strs,tc) = composeTree' treecluster
mapM putStrLn strs
--putStrLn "Room cluster layout:"
--putStrLn $ drawTreeSubLabelling $ fmap snd treecluster
--let rmtree = inorderNumberTree $ expandTree $ fmap fst treecluster
let rmtree = inorderNumberTree $ tc
putStrLn "Room layout (compact): "
putStrLn $ compactDrawTree $ fmap (show . snd) rmtree
let nameshow (r,rid) = _rmName r ++ "-" ++ show rid
src/Dodge/LockAndKey.hs
+4 -3
View File
@@ -1,5 +1,6 @@
--{-# LANGUAGE TupleSections #-}
module Dodge.LockAndKey where
import Dodge.UseAll
import Dodge.Data
import Dodge.Tree
--import Dodge.LevelGen.Data
@@ -114,7 +115,7 @@ someCrits = do
corridorBoss :: RandomGen g => Creature -> State g (LabTree Room)
corridorBoss cr = do
endroom <- bossRoom cr
return (treeFromPost (replicate 5 $ corridor)
( endroom)
,TreeSubLabelling ("corridorBoss-"++_crName cr) Nothing)
return ( toOnward ("corridorBoss-"++_crName cr)
, treeFromPost (replicate 5 $ corridor) ( endroom)
)
src/Dodge/Room/BlinkAcross.hs
+4 -2
View File
@@ -1,6 +1,7 @@
module Dodge.Room.BlinkAcross where
--import Dodge.LevelGen.Data
import Dodge.PlacementSpot
import Dodge.UseAll
import Dodge.Data
import Dodge.Tree
--import Dodge.RoomLink
@@ -38,8 +39,9 @@ blinkAcrossChallenge = do
teleFromRoom <- shuffleLinks $ roomRectAutoLinks 200 200
teleToRoom <- shuffleLinks $ roomRectAutoLinks 200 200
emptylink <- shuffleLinks emptyCorridor
return (treeFromPost [ teleFromRoom, emptylink] (useAll teleToRoom)
, TreeSubLabelling "blinkAcrossChallenge" Nothing)
return (toOnward "blinkAcrossChallenge"
,treeFromPost [ teleFromRoom, emptylink] (useAll teleToRoom)
)
emptyCorridor :: Room
emptyCorridor = corridor & rmPolys .~ []
src/Dodge/Room/Branch.hs
+2 -1
View File
@@ -6,6 +6,7 @@ module Dodge.Room.Branch
--import Geometry
--import Dodge.LevelGen.Data
import Dodge.Data
import Dodge.UseAll
import Dodge.Room.Door
import Dodge.Room.Link
import Dodge.Room.Procedural
@@ -23,5 +24,5 @@ branchRectWith t = do
rt <- shuffleLinks $ roomRectAutoLinks x y
return $ Node ( rt)
[ Node (useAll door) []
, changeTo <$> treeFromTrunk [ door] b
, useSide <$> treeFromTrunk [ door] b
]
src/Dodge/Room/Containing.hs
+8
View File
@@ -25,6 +25,14 @@ roomsContaining crs its = do
++ "-items:" ++ intercalate "," (map (show . _iyBase . _itType) its))
, pure $ useAll endroom
)
roomsContaining' :: RandomGen g => [Creature] -> [Item] -> State g (Tree Room)
roomsContaining' crs its = do
endroom <- join $ takeOne
[ randomFourCornerRoomCrsIts crs its
, tanksRoom crs its
]
return (pure $ useAll endroom
)
pedestalRoom :: RandomGen g => Item -> State g Room
pedestalRoom it = do
src/Dodge/Room/Start.hs
+18 -17
View File
@@ -49,27 +49,27 @@ powerFakeout = do
`treeFromPost` useAll door
startRoom :: RandomGen g => Int -> State g (LabTree Room)
startRoom i = join (uncurry takeOneWeighted $ unzip
startRoom i = join (takeOne $
[-- (,) (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 <&> (toOnward "rezBoxesWpCrit"))
, (,) one (runPastStart i <&> (toOnward ("runPastStart " ++ show i)))
, (,) one (startCrafts >>= roomsContaining' [] >>= rezBoxThenRooms <&>
(toOnward "startCrafts >>= roomsContaining [] >>= rezBoxThenRooms"))
(rezBoxesWp <&> (toOnward "rezBoxesWp",))
, (rezBoxThenWeaponRoom i)
, (rezBoxesWpCrit <&> (toOnward "rezBoxesWpCrit",))
, (runPastStart i <&> (toOnward ("runPastStart " ++ show i),))
-- , ((startCrafts >>= roomsContaining' [] >>= rezBoxThenRooms) <&>
-- (toOnward "startCrafts >>= roomsContaining [] >>= rezBoxThenRooms",))
])
<&> over (_2 . topLabel) ("startRoom:"++)
where
roomsContaining' a b = fst <$> roomsContaining a b
one = 1::Float
randomChallenges :: RandomGen g => State g (LabTree Room)
randomChallenges = join (takeOne
[fmap (return . useAll) doubleCorridorBarrels <&> (,TreeSubLabelling "doubleCorridorBarrels" Nothing)
,shootingRange
,fmap (return . useAll) twinSlowDoorChasers <&> (,TreeSubLabelling "twinSlowDoorChasers" Nothing)
]) <&> over (_2 . topLabel) ("randomChallenges:"++)
randomChallenges = shootingRange
-- join (takeOne
-- [fmap (return . useAll) doubleCorridorBarrels <&> (,TreeSubLabelling "doubleCorridorBarrels" Nothing)
-- ,shootingRange
-- ,fmap (return . useAll) twinSlowDoorChasers <&> (,TreeSubLabelling "twinSlowDoorChasers" Nothing)
-- ]) -- <&> over (_2 . topLabel) ("randomChallenges:"++)
runPastStart :: RandomGen g => Int -> State g (Tree Room)
runPastStart i = do
@@ -85,15 +85,16 @@ rezBoxStart = do
rezBoxesThenWeaponRoom :: RandomGen g => Int -> State g (Tree Room,String)
rezBoxesThenWeaponRoom i = do
rboxes <- rezBoxes
wroom <- fst <$> weaponRoom i
wroom <- snd <$> weaponRoom i
return (rboxes `passUntiluseAll` [wroom] , "rezBoxesThenWeaponRoom " ++ show i)
rezBoxThenWeaponRoom :: RandomGen g => Int -> State g (LabTree Room)
rezBoxThenWeaponRoom i = do
rcol <- rezColor
(wroom,wroomname) <- weaponRoom i
return (treeFromTrunk [ rezBox rcol, door] wroom
, TreeSubLabelling ("rezBoxThenWeaponRoom "++ show i) (Just $ return wroomname))
(_,wroom) <- weaponRoom i
return (toOnward ("rezBoxThenWeaponRoom "++ show i)
, treeFromTrunk [ rezBox rcol, door] wroom
)
rezBoxThenRoom :: RandomGen g => Room -> State g (Tree Room)
rezBoxThenRoom r = do
src/Dodge/Room/Warning.hs
+1
View File
@@ -1,5 +1,6 @@
--{-# LANGUAGE TupleSections #-}
module Dodge.Room.Warning where
import Dodge.UseAll
import Dodge.Terminal
--import Dodge.LevelGen.Data
import Dodge.PlacementSpot
src/Dodge/Tree/Compose.hs
+17 -4
View File
@@ -4,18 +4,20 @@ module Dodge.Tree.Compose
( --expandTree
--, pure
--, pure
--, passUntiluseAll
--, chainUses
--, useAllAtEnd
--, changeTo
--, overwriteLabel
--, applyToCompRoot
composeTree
passUntiluseAll -- this should be moved, and the dependency on Dodge.Data removed
, overwriteLabel
, composeTree
, composeTree'
, composeTreeRand
-- , compTree
) where
import Dodge.Data
import Dodge.Tree.Compose.Data
import Dodge.RoomCluster.Data
import TreeHelp
import Dodge.Base
import LensHelp
@@ -39,6 +41,12 @@ import Data.Maybe
--applyToCompRoot :: (a -> a) -> Tree a -> Tree a
--applyToCompRoot f = over root (unCompose %~ f)
overwriteLabel :: Int -> Tree Room -> [Tree Room] -> Tree Room
overwriteLabel i t ts = safeUpdateSingleNode
(\rm -> LabelCluster 0 `elem` (rm ^?! rmClusterStatus . csLinks))
((branches .~ ts) . (root . rmClusterStatus . csLinks . at (LabelCluster 0) .~ Nothing))
t
--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
@@ -47,7 +55,12 @@ import Data.Maybe
-- islabel _ = False
-- update (Node x _) = Node (f $ _unCompose x) ts
--passUntiluseAll :: Tree a -> [Tree a] -> Tree a
passUntiluseAll :: Tree Room -> [Tree Room] -> Tree Room
passUntiluseAll t ts = updateAllNodes
((OnwardCluster `elem`) . (^?! rmClusterStatus . csLinks))
((branches .~ ts) . (root . rmClusterStatus . csLinks . at OnwardCluster .~ Nothing))
t
--passUntiluseAll (Node (useAll x) _) ts' = Node ( x) ts'
--passUntiluseAll (Node cn ts) ts' = Node ( (_unCompose cn)) $ map (`passUntiluseAll` ts') ts
src/Dodge/UseAll.hs
+24
View File
@@ -0,0 +1,24 @@
module Dodge.UseAll where
import Dodge.Data
import Control.Lens
import qualified Data.Set as S
toOnward :: String -> Room -> Maybe ([String],Room)
toOnward s rm
| OnwardCluster `elem` rm ^?! rmClusterStatus . csLinks = Just ([s],rm)
| otherwise = Nothing
toClusterLabel :: Int -> String -> Room -> Maybe ([String],Room)
toClusterLabel i s rm
| LabelCluster i `elem` rm ^?! rmClusterStatus . csLinks = Just ([s],rm)
| otherwise = Nothing
useAll :: Room -> Room
useAll = rmClusterStatus . csLinks .~ S.singleton OnwardCluster
useSide :: Room -> Room
useSide = rmClusterStatus . csLinks .~ S.singleton SideCluster
useLabel :: Int -> Room -> Room
useLabel i = rmClusterStatus . csLinks .~ S.singleton (LabelCluster i)
src/TreeHelp.hs
+9
View File
@@ -19,6 +19,7 @@ module TreeHelp
, addToTrunk
, inorderNumberTree
, updateSingleNodes
, updateAllNodes
, updateRandNode
, safeUpdateSingleNode
, msafeUpdateSingleNode
@@ -80,6 +81,14 @@ applyToSubforest is = applyToSubtree is . over branches
-- | otherwise = Node x (applyToSubTrunkBy cond f t : ts)
--applyToSubTrunkBy _ _ t = t
updateAllNodes :: (a -> Bool) -> (Tree a -> Tree a) -> Tree a -> Tree a
updateAllNodes f update t@(Node x ts)
| f x = update t
| otherwise = updateChildren
where
updateChildren = Node x (map (updateAllNodes f update) ts)
-- gives the list of all updates to a single node
-- there must be a better way of doing something like this
updateSingleNodes :: (a -> Bool) -> (Tree a -> Tree a) -> Tree a -> [Tree a]