diff --git a/src/Dodge/Annotation.hs b/src/Dodge/Annotation.hs index 50a527828..053098b5d 100644 --- a/src/Dodge/Annotation.hs +++ b/src/Dodge/Annotation.hs @@ -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) diff --git a/src/Dodge/Annotation/Data.hs b/src/Dodge/Annotation/Data.hs index aadbf8de3..6006e69e3 100644 --- a/src/Dodge/Annotation/Data.hs +++ b/src/Dodge/Annotation/Data.hs @@ -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 diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index d715ca578..92cac428d 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -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 diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index f2c93c092..2e9a31cba 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -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 diff --git a/src/Dodge/LockAndKey.hs b/src/Dodge/LockAndKey.hs index 63373a000..4c439fe9c 100644 --- a/src/Dodge/LockAndKey.hs +++ b/src/Dodge/LockAndKey.hs @@ -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) + ) diff --git a/src/Dodge/Room/BlinkAcross.hs b/src/Dodge/Room/BlinkAcross.hs index 25e9d3c83..88ae6fcfe 100644 --- a/src/Dodge/Room/BlinkAcross.hs +++ b/src/Dodge/Room/BlinkAcross.hs @@ -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 .~ [] diff --git a/src/Dodge/Room/Branch.hs b/src/Dodge/Room/Branch.hs index 08baee1ae..66a17231a 100644 --- a/src/Dodge/Room/Branch.hs +++ b/src/Dodge/Room/Branch.hs @@ -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 ] diff --git a/src/Dodge/Room/Containing.hs b/src/Dodge/Room/Containing.hs index edad67272..d64d122f0 100644 --- a/src/Dodge/Room/Containing.hs +++ b/src/Dodge/Room/Containing.hs @@ -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 diff --git a/src/Dodge/Room/Start.hs b/src/Dodge/Room/Start.hs index e943d2124..d3c414678 100644 --- a/src/Dodge/Room/Start.hs +++ b/src/Dodge/Room/Start.hs @@ -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 diff --git a/src/Dodge/Room/Warning.hs b/src/Dodge/Room/Warning.hs index a2009ea2f..7af39a5df 100644 --- a/src/Dodge/Room/Warning.hs +++ b/src/Dodge/Room/Warning.hs @@ -1,5 +1,6 @@ --{-# LANGUAGE TupleSections #-} module Dodge.Room.Warning where +import Dodge.UseAll import Dodge.Terminal --import Dodge.LevelGen.Data import Dodge.PlacementSpot diff --git a/src/Dodge/Tree/Compose.hs b/src/Dodge/Tree/Compose.hs index 9f186575c..c58609c94 100644 --- a/src/Dodge/Tree/Compose.hs +++ b/src/Dodge/Tree/Compose.hs @@ -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 diff --git a/src/Dodge/UseAll.hs b/src/Dodge/UseAll.hs new file mode 100644 index 000000000..f50e004d4 --- /dev/null +++ b/src/Dodge/UseAll.hs @@ -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) diff --git a/src/TreeHelp.hs b/src/TreeHelp.hs index 0167d8e35..1c4277891 100644 --- a/src/TreeHelp.hs +++ b/src/TreeHelp.hs @@ -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]