Implement more general tree composition

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