BROKEN partial redo of room tree composition

src/Dodge/Annotation.hs

@@ -53,7 +53,7 @@ roomThenCorridor theRoom = fmap
     (shuffleLinks corridor)
 
 {- | Create a random room tree structure from a list of annotations.  -}
-anoToRoomTree :: [Annotation] -> State StdGen (LabSubCompTree Room)
+anoToRoomTree :: [Annotation] -> State StdGen (Room -> Maybe ([String],Room), Tree Room)
 anoToRoomTree anos = case anos of
     [AnoApplyInt i f] -> f i
 --    [AnoApplyInt' i f str] -> f i <&> (,TreeSubLabelling str Nothing)

src/Dodge/Floor.hs

@@ -100,5 +100,5 @@ initialAnoTree = padSucWithDoors $ treeFromPost
         <&> (,TreeSubLabelling "telRoomLev" Nothing)]
 
 {- | A test level tree. -}
-initialRoomTree :: State StdGen (Tree (LabSubCompTree Room))
+initialRoomTree :: State StdGen (Tree (Room -> Maybe (String,Room), Tree Room))
 initialRoomTree = mapM anoToRoomTree initialAnoTree

src/Dodge/Room/Containing.hs

@@ -8,6 +8,7 @@ import Dodge.Room.Procedural
 import Dodge.Room.Tanks
 import Dodge.Room.Link
 import Dodge.Room.Ngon
+import Dodge.UseAll
 import LensHelp
 import Geometry
 --import Dodge.Item.Equipment
@@ -20,9 +21,10 @@ roomsContaining crs its = do
         [ randomFourCornerRoomCrsIts crs its 
         , tanksRoom crs its
         ]
-    return (treeFromPost [] $ UseAll endroom
-        ,TreeSubLabelling ("roomsContaining-creatures:" ++ intercalate "," (map _crName crs) 
-            ++ "-items:" ++ intercalate "," (map (show . _iyBase . _itType) its)) Nothing)
+    return (toOnward ("roomsContaining-creatures:" ++ intercalate "," (map _crName crs) 
+            ++ "-items:" ++ intercalate "," (map (show . _iyBase . _itType) its))
+        , pure $ useAll endroom
+        )
 
 pedestalRoom :: RandomGen g => Item -> State g Room
 pedestalRoom it = do

src/Dodge/Room/GlassLesson.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE TupleSections #-}
 module Dodge.Room.GlassLesson where
+import Dodge.UseAll
 import Dodge.RoomLink
 import Dodge.Creature
 import Dodge.LevelGen.Data
@@ -18,19 +19,18 @@ import LensHelp
 
 import qualified Data.Set as S
 --import Control.Monad.Loops
-glassLesson :: RandomGen g => State g (SubCompTree Room)
+glassLesson :: RandomGen g => State g (Tree Room)
 glassLesson = do
     i <- takeOne [1,2,3]
-    corridors <- replicateM i $ PassDown <$> shuffleLinks corridor
-    return $ Node (PassDown botRoom) 
-        [ singleUseNone $ door & rmConnectsTo .~ fromWest North 1
+    corridors <- replicateM i $ shuffleLinks corridor
+    return $ Node botRoom
+        [ pure $ door & rmConnectsTo .~ fromWest North 1
         , uppers
-        , treeFromPost (PassDown (door & rmConnectsTo .~ S.member (OnEdge East)) 
-            : corridors) $ UseAll door]
+        , treeFromPost ( (door & rmConnectsTo .~ S.member (OnEdge East)) 
+            : corridors) $ useAll door]
   where 
     fromWest edge i s = S.member (OnEdge edge) s && S.member (FromWest i) s
-    uppers = Node (PassDown $ door & rmConnectsTo .~ fromWest North 0)
-        [singleUseNone topRoom]
+    uppers = Node (door & rmConnectsTo .~ fromWest North 0) [pure topRoom]
     botRoom = roomRect 200 200 1 1 
         & rmPmnts .~ botplmnts 
         & rmLinks %~ setInLinksByType (OnEdge West)
@@ -54,6 +54,6 @@ glassLesson = do
             ]
         ]
 glassLessonRunPast :: RandomGen g => State g (LabSubCompTree Room)
-glassLessonRunPast = (f <$> glassLesson) <&> (,TreeSubLabelling "glassLessonRunPast" Nothing)
+glassLessonRunPast = (f <$> glassLesson) <&> (toOnward "glassLessonRunPast",)
   where
-    f (Node r rs) = Node r $ return (UseLabel 0 $ door & rmConnectsTo .~ S.member (OnEdge West)) : rs
+    f (Node r rs) = Node r $ return (useLabel 0 $ door & rmConnectsTo .~ S.member (OnEdge West)) : rs

src/Dodge/RoomCluster/Data.hs

@@ -9,7 +9,7 @@ data ClusterStatus = ClusterStatus
     , _csLinks :: S.Set ClusterLink
     }
 
-data ClusterLink = OnwardCluster | SideCluster
-  deriving (Ord,Eq,Enum,Show)
+data ClusterLink = OnwardCluster | SideCluster | LabelCluster Int
+  deriving (Ord,Eq,Show)
 
 makeLenses ''ClusterStatus

src/Dodge/Tree/Compose.hs

@@ -1,16 +1,16 @@
 {-# LANGUAGE TupleSections #-}
 {-| Combining and composing trees of trees.  -}
 module Dodge.Tree.Compose
-    ( expandTree
-    , singleUseAll
-    , singleUseNone
-    , passUntilUseAll
-    , chainUses
-    , useAllAtEnd
-    , changeToPassDown
-    , overwriteLabel
-    , applyToCompRoot
-    , composeTree
+    ( --expandTree
+    --, singleUseAll
+    --, singleUseNone
+    --, passUntilUseAll
+    --, chainUses
+    --, useAllAtEnd
+    --, changeToPassDown
+    --, overwriteLabel
+    --, applyToCompRoot
+     composeTree
     , composeTree'
     , composeTreeRand
 --    , compTree
@@ -26,49 +26,49 @@ import Data.Foldable
 import System.Random
 import Data.Maybe
 
-expandTree :: CompTree a -> Tree a
-expandTree (Node rt extChildren) = case rt of
-    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 (SplitDown x)  xs  -> Node x $ map expandTree $ zipWith Node xs 
-            $ map (:[]) extChildren ++ repeat []
+--expandTree :: CompTree a -> Tree a
+--expandTree (Node rt extChildren) = case rt of
+--    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 (SplitDown x)  xs  -> Node x $ map expandTree $ zipWith Node xs 
+--            $ map (:[]) extChildren ++ repeat []
 
-applyToCompRoot :: (a -> a) -> SubCompTree a -> SubCompTree a
-applyToCompRoot f = over root (unCompose %~ f)
+--applyToCompRoot :: (a -> a) -> SubCompTree a -> SubCompTree a
+--applyToCompRoot f = over root (unCompose %~ f)
 
-overwriteLabel :: Int -> (a -> ComposingNode a) -> SubCompTree a -> [SubCompTree a] -> SubCompTree a
-overwriteLabel i f t ts = errorHead ("tried to overwriteLabel " ++ show i)
-    $ updateSingleNodes islabel update t
-  where
-    islabel (UseLabel j _) | i == j = True
-    islabel _ = False
-    update (Node x _) = Node (f $ _unCompose x) ts
+--overwriteLabel :: Int -> (a -> ComposingNode a) -> SubCompTree a -> [SubCompTree a] -> SubCompTree a
+--overwriteLabel i f t ts = errorHead ("tried to overwriteLabel " ++ show i)
+--    $ updateSingleNodes islabel update t
+--  where
+--    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 :: 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
 
-chainUses :: [SubCompTree a] -> SubCompTree a
-chainUses (t:s:ts) = chainUses (passUntilUseAll t [s]:ts)
-chainUses [t] = t
-chainUses []  = error "tried to concatenate an empty list of SubCompTrees"
+--chainUses :: [SubCompTree a] -> SubCompTree a
+--chainUses (t:s:ts) = chainUses (passUntilUseAll t [s]:ts)
+--chainUses [t] = t
+--chainUses []  = error "tried to concatenate an empty list of SubCompTrees"
 
-singleUseAll :: a -> Tree (ComposingNode a)
-singleUseAll x = Node (UseAll x) []
+--singleUseAll :: a -> Tree (ComposingNode a)
+--singleUseAll x = Node (UseAll x) []
 
-useAllAtEnd :: Tree a -> SubCompTree a
-useAllAtEnd tree = case tree of
-    Node x (t:ts)   -> Node (PassDown x) (useAllAtEnd t : map (fmap UseNone) ts)
-    Node x []       -> Node (UseAll x) []
+--useAllAtEnd :: Tree a -> SubCompTree a
+--useAllAtEnd tree = case tree of
+--    Node x (t:ts)   -> Node (PassDown x) (useAllAtEnd t : map (fmap UseNone) ts)
+--    Node x []       -> Node (UseAll x) []
 
-singleUseNone :: a -> SubCompTree a
-singleUseNone x = Node (UseNone x) []
+--singleUseNone :: a -> SubCompTree a
+--singleUseNone x = Node (UseNone x) []
 
-changeToPassDown :: ComposingNode a -> ComposingNode a
-changeToPassDown x = PassDown (_unCompose x)
+--changeToPassDown :: ComposingNode a -> ComposingNode a
+--changeToPassDown x = PassDown (_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

@@ -10,9 +10,9 @@ data ComposingNode a
     | UseSome   {_composeIndices :: [Int], _unCompose :: a}
     | UseNone   {_unCompose :: 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 SubCompTree a = Tree a
+type CompTree a = Tree (Tree a)
+type LabSubCompTree a = (a -> Maybe ([String],a),Tree a)
 type LabCompTree a = Tree (LabSubCompTree a)
 data TreeSubLabelling = TreeSubLabelling
     { _topLabel :: String
@@ -20,3 +20,4 @@ data TreeSubLabelling = TreeSubLabelling
     }
 makeLenses ''ComposingNode
 makeLenses ''TreeSubLabelling
+