Redo tree composition

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)
+            [ (toOnward "door", return (useAll door))
-            , (treeFromPost [ door,  thecor] (useAll door)
+            , (toOnward "twoDoors"
-                ,TreeSubLabelling "twoDoors" Nothing)
+                ,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'
+        let keyroom = snd keyroom'
-        return (overwriteLabel 0 UseNone lr [keyroom]
+        return (toOnward ("PassthroughLockKeyLists-"++show ii)
-            ,TreeSubLabelling ("PassthroughLockKeyLists-"++show ii) 
+            , overwriteLabel 0 lr [keyroom]
-                (Just $ treeFromPost [snd lr'] (snd 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
+        branchRectWith . pure $ treeFromPost [corridor,corridor] br
-    (TreasureAno crs loot : _) -> branchRectWith . fmap (pure . ) $ lootRoom crs loot
+    (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

@@ -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

@@ -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
+    , [SpecificRoom $ return ( toOnward "chaseCrit+armourChaseCrit rectRoom"
-        & rmPmnts .++~ [spNoID anyUnusedSpot (PutCrit invisibleChaseCrit)
+            , 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

@@ -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:"
+        (strs,tc) = composeTree' treecluster
-    putStrLn $ drawTreeSubLabelling $ fmap snd treecluster
+    mapM putStrLn strs
-    let rmtree = inorderNumberTree $ expandTree $ fmap fst treecluster
+    --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

@@ -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) 
+    return ( toOnward ("corridorBoss-"++_crName cr)
-                            ( endroom)
+        , treeFromPost (replicate 5 $  corridor) ( endroom)
-        ,TreeSubLabelling ("corridorBoss-"++_crName cr) Nothing)
+        )
 

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)
+    return (toOnward "blinkAcrossChallenge"
-        , TreeSubLabelling "blinkAcrossChallenge" Nothing)
+        ,treeFromPost [ teleFromRoom, emptylink] (useAll teleToRoom)
+        )
 
 emptyCorridor :: Room
 emptyCorridor = corridor & rmPolys .~ []

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
         ]

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

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",))
+      (rezBoxesWp <&>      (toOnward "rezBoxesWp",))
-    , (,) one (rezBoxThenWeaponRoom i)
+    , (rezBoxThenWeaponRoom i)
-    , (,) one (rezBoxesWpCrit <&> (toOnward "rezBoxesWpCrit"))
+    , (rezBoxesWpCrit <&> (toOnward "rezBoxesWpCrit",))
-    , (,) one (runPastStart i <&> (toOnward ("runPastStart " ++ show i)))
+    , (runPastStart i <&> (toOnward ("runPastStart " ++ show i),))
-    , (,) one (startCrafts >>= roomsContaining' [] >>= rezBoxThenRooms <&> 
+--    , ((startCrafts >>= roomsContaining' [] >>= rezBoxThenRooms) <&> 
-        (toOnward "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
+randomChallenges = shootingRange
-    [fmap (return . useAll) doubleCorridorBarrels <&> (,TreeSubLabelling "doubleCorridorBarrels" Nothing)
+--        join (takeOne
-    ,shootingRange
+--    [fmap (return . useAll) doubleCorridorBarrels <&> (,TreeSubLabelling "doubleCorridorBarrels" Nothing)
-    ,fmap (return . useAll) twinSlowDoorChasers <&> (,TreeSubLabelling "twinSlowDoorChasers" Nothing)
+--    ,shootingRange
-    ]) <&> over (_2 . topLabel) ("randomChallenges:"++)
+--    ,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
+    (_,wroom) <- weaponRoom i
-    return (treeFromTrunk [ rezBox rcol, door] wroom
+    return (toOnward ("rezBoxThenWeaponRoom "++ show i)
-         , TreeSubLabelling ("rezBoxThenWeaponRoom "++ show i) (Just $ return wroomname))
+        , treeFromTrunk [ rezBox rcol, door] wroom
+        )
 
 rezBoxThenRoom :: RandomGen g => Room -> State g (Tree Room)
 rezBoxThenRoom r = do

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

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
 

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)

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]