Improve composing tree logging

src/Dodge/Annotation.hs

@@ -7,7 +7,7 @@ module Dodge.Annotation
 import Dodge.UseAll
 import RandomHelp
 import Dodge.Tree
-import Dodge.Data
+--import Dodge.Data
 import Dodge.Annotation.Data
 import LensHelp
 

src/Dodge/LevelGen.hs

@@ -37,6 +37,9 @@ layoutLevelFromSeed i seed = do
     let g = mkStdGen seed
     let treecluster = evalState initialRoomTree (g,0)
     --tc <- composeAndLog [0] (\str -> putStrLn str >> appendFile "log/treeCluster" str) treecluster
+--    let labts = decomposeTree $ numMetaTree treecluster
+    let labts = decomposeSelfTree $ numSelfTree $ combineTree _rmName treecluster
+    mapM_ (putStrLn . drawTree . fmap show) labts
     let tc = composeTree treecluster
     ----    (strs,tc) = composeTree' treecluster
     ----appendFile "log/TreeCluster" ("Seed: "++ show seed)

src/Dodge/Room/Room.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE TupleSections #-}
+--{-# LANGUAGE TupleSections #-}
 module Dodge.Room.Room where
 import Data.Tile
 import Dodge.UseAll

src/Dodge/Tree/Compose.hs

@@ -4,6 +4,11 @@ module Dodge.Tree.Compose
     ( tToBTree
     , overwriteLabel
     , composeTree
+    , decomposeTree
+    , numMetaTree
+    , numSelfTree
+    , combineTree
+    , decomposeSelfTree
 --    , composeTree'
     , shiftChildren
     , attachTree
@@ -22,11 +27,13 @@ import TreeHelp
 --import Dodge.Base
 import LensHelp
 
+import Data.Tuple
 --import Data.Bifunctor
 --import Control.Monad.State
 --import Data.Foldable
 --import System.Random
 import Data.Maybe
+import Control.Monad.State
 
 overwriteLabel :: Int -> Tree Room -> [Tree Room] -> Tree Room
 overwriteLabel i t ts = safeUpdateSingleNode 
@@ -176,6 +183,29 @@ shiftChildren (Node (ts,x) ts') = Node x (ts ++ map shiftChildren ts')
 composeTree :: MetaTree a b -> Tree a
 composeTree mt = attachList' (composeNode $ _mtTree mt) (_mtBranches mt)
 
+mtTopLabels :: MetaTree a b -> Tree b
+mtTopLabels (MTree lab _ bs) = Node lab (map (mtTopLabels . _mbTree) bs)
+
+mtUnderLabels :: MetaTree a b -> [Tree b]
+mtUnderLabels mt = maybe [] decomposeTree (mt ^? mtTree . nodeMetaTree)
+    ++ concatMap (mtUnderLabels . _mbTree) (_mtBranches mt)
+
+decomposeTree :: MetaTree a b -> [Tree b]
+decomposeTree mt = mtTopLabels mt : mtUnderLabels mt
+
+decomposeSelfTree :: SelfTree a -> [Tree a]
+decomposeSelfTree st = fmap fst (_unST st) : concatMap (f . snd) (_unST st)
+  where
+    f (Left t) = [t]
+    f (Right st') = decomposeSelfTree st'
+
+combineTree :: (a -> b) -> MetaTree a b -> SelfTree b
+combineTree f mt = case _mtTree mt of
+    NodeTree t -> ST (Node (_mtLabel mt,Left $ fmap f t) (fmap (_unST . combineTree f . _mbTree) $ _mtBranches mt))
+    --NodeTree t -> ST (Node (Left $ fmap f t) _)
+    NodeMTree mt' -> ST (Node (_mtLabel mt,Right $ combineTree f mt') 
+        $ map (_unST . combineTree f . _mbTree) $ _mtBranches mt)
+
 composeNode :: MetaNode a b -> Tree a
 composeNode (NodeTree t) = t
 composeNode (NodeMTree mt) = composeTree mt
@@ -203,3 +233,24 @@ toOnward rm
         = Just (rm & rmClusterStatus . csLinks . at OnwardCluster .~ Nothing)
     | otherwise = Nothing
 
+numSelfTree st = evalState (numSelfTree' st) [0]
+
+numSelfTree' :: SelfTree a -> State [Int] (SelfTree ([Int],a))
+numSelfTree' (ST (Node lrt bs)) = do
+    is <- get
+    modify (ix 0 +~ 1)
+    bs' <- mapM (fmap _unST . numSelfTree' . ST) bs
+    case lrt of
+        (y,Left t) -> return $ ST (Node ((is,y),Left $ fmap ((_1 %~ (\x -> x:is)) . swap) $ numTraversable t) bs')
+        (y,Right mt') -> return $ ST (Node ((is,y),Right (evalState (numSelfTree' mt') (0:is))) bs')
+--    return $ MTree (is,lab) (mn & nodeMetaTree %~ (\nmt -> evalState (numMetaTree' nmt) (0:is))) bs'
+
+numMetaTree :: MetaTree a String -> MetaTree a ([Int],String)
+numMetaTree mt = evalState (numMetaTree' mt) [0]
+
+numMetaTree' :: MetaTree a b -> State [Int] (MetaTree a ([Int],b))
+numMetaTree' (MTree lab mn bs) = do
+    is <- get
+    modify (ix 0 +~ 1)
+    bs' <- mapM (mbTree %%~ numMetaTree') bs
+    return $ MTree (is,lab) (mn & nodeMetaTree %~ (\nmt -> evalState (numMetaTree' nmt) (0:is))) bs'

src/Dodge/Tree/Compose/Data.hs

@@ -10,6 +10,11 @@ data MetaTree a b = MTree {_mtLabel :: b , _mtTree :: MetaNode a b, _mtBranches
 data MetaNode a b = NodeTree {_nodeTree :: Tree a} | NodeMTree {_nodeMetaTree :: MetaTree a b}
 data MetaBranch a b = MBranch {_mbAttach :: a -> Maybe a, _mbTree :: MetaTree a b}
 
+newtype SelfTree a = ST {_unST :: Tree (a,Either (Tree a) (SelfTree a))}
+
 makeLenses ''MetaTree
 makeLenses ''MetaBranch
 makeLenses ''MetaNode
+
+instance Functor (MetaTree a) where
+    fmap f (MTree b mn bs) = MTree (f b) (mn & nodeMetaTree %~ fmap f) (map (mbTree %~ fmap f) bs)