Implement more general tree composition

src/Dodge/Floor.hs

@@ -36,7 +36,7 @@ import RandomHelp
 --import qualified Data.IntMap.Strict as IM
 
 initialAnoTree :: Tree [Annotation]
-initialAnoTree = padSucWithDoors $ treeFromPost 
+initialAnoTree = padSucWithDoors $ treePost 
     [[AnoApplyInt 110 startRoom]
     , [PassthroughLockKeyLists 2 keyCardRunPastRand itemRooms]
     , [SpecificRoom $ warningRooms 777777]
@@ -94,8 +94,8 @@ initialAnoTree = padSucWithDoors $ treeFromPost
 --    ,[TreasureAno [addArmour autoCrit,addArmour autoCrit] [launcher]]
 --    ,[Corridor]
     ,[SpecificRoom $ randomFourCornerRoom [] >>= rToOnward "randomFourCornerRoom" . pure . cleatOnward ]
+    ,[SpecificRoom $ telRoomLev 1 >>= rToOnward "telRoomLev" . pure . cleatOnward]
     ]
-    [SpecificRoom $ telRoomLev 1 >>= rToOnward "telRoomLev" . pure . cleatOnward]
 
 {- | A test level tree. -}
 initialRoomTree :: State StdGen (Tree (Room -> Maybe ([String],Room), Tree Room))

src/Dodge/Tree/Compose.hs

@@ -15,10 +15,11 @@ module Dodge.Tree.Compose
     , shiftChildren
     , attachTree
     , composeTreeRand
+    , composeAndLog
 --    , compTree
     ) where
 import Dodge.Data
---import Dodge.Tree.Compose.Data
+import Dodge.Tree.Compose.Data
 --import Dodge.RoomCluster.Data
 import TreeHelp
 --import Dodge.Base
@@ -156,3 +157,26 @@ shiftChildren (Node (ts,x) ts') = Node x (ts ++ map shiftChildren ts')
 --attachChildren t = moveToChildren . foldr mAttachToNode t'
 --  where
 --    t' = fmap (\(x,y) -> (x,y,[])) t
+
+logMB :: MetaBranch a -> Tree String
+logMB (MBranch str _ mt) = root ++.~ (str ++ ":") $ logMT mt
+
+logMT :: MetaTree a -> Tree String
+logMT mt = case mt of
+    MTree str _ branches -> Node ("M:"++str) $ map logMB branches
+    BTree str _ branches -> Node str $ map logMT branches
+
+composeAndSubLog :: MetaTree a -> IO (Tree a)
+composeAndSubLog mt = case mt of
+    mt@MTree{} -> composeAndLog mt
+    bt -> do
+        branches <- mapM composeAndSubLog $ _btBranches bt
+        return $ Node (_btValue bt) branches
+
+composeAndLog :: MetaTree a -> IO (Tree a)
+composeAndLog mt = case mt of
+    mt@MTree{} -> do
+        putStrLn $ drawTree $ logMT mt
+        rt <- composeAndLog $ _mtTree mt
+        branches <- mapM (\mb -> (_mbAttach mb,) <$> composeAndSubLog (_mbTree mb)) $ _mtBranches mt
+        return $ attachList rt $ map pure branches

src/Dodge/Tree/Compose/Data.hs

@@ -3,19 +3,22 @@
 module Dodge.Tree.Compose.Data where
 import Data.Tree
 import Control.Lens
-data ComposingNode a
+
-    = SplitDown {_unCompose :: a}
+data MetaBranch a 
---    | useAll    {_unCompose :: a}
+    = MBranch {_mbLabel :: String, _mbAttach :: a -> Maybe a, _mbTree :: MetaTree a}
-    | UseSome   {_composeIndices :: [Int], _unCompose :: a}
+
-    | UseNone   {_unCompose :: a}
+data MetaTree a
---    | useLabel  {_composeIndex :: Int, _unCompose :: a} -- defaults to using no children
+    = MTree {_mtLabel :: String , _mtTree :: MetaTree a , _mtBranches :: [MetaBranch a] }
-type CompTree a = Tree (Tree a)
+    | BTree {_btLabel :: String , _btValue :: a ,         _btBranches :: [MetaTree a] }
+
+--type CompTree a = Tree (Tree 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)
     }
-makeLenses ''ComposingNode
 makeLenses ''TreeSubLabelling
+makeLenses ''MetaTree
+makeLenses ''MetaBranch