Cleanup

src/Dodge/LevelGen.hs

@@ -36,15 +36,10 @@ layoutLevelFromSeed i seed = do
     appendFile "log/attemptedSeeds" $ show seed ++ "\n"
     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
+    mapM_ ((\str -> putStrLn str >> appendFile "log/treeCluster" str) . smallDrawTree . fmap showIntsString) 
+        labts
     let tc = composeTree treecluster
-    ----    (strs,tc) = composeTree' treecluster
-    ----appendFile "log/TreeCluster" ("Seed: "++ show seed)
-    ----mapM_ (appendFile "log/treeCluster" . ('\n':))  strs
-    ----mapM_ putStrLn strs
     let rmtree = inorderNumberTree tc
     putStrLn "Room layout (compact): "
     putStrLn $ compactDrawTree $ fmap (show . snd) rmtree
@@ -52,6 +47,7 @@ layoutLevelFromSeed i seed = do
     appendFile "log/aGeneratedRoomLayout" ("Seed: "++ show seed)
     appendFile "log/aGeneratedRoomLayout" $ drawTree $ fmap nameshow rmtree
     putStrLn "Layout with room names (also written to log/aGeneratedRoomLayout):"
+    putStrLn $ smallDrawTree $ fmap nameshow rmtree
     mrs <- positionRoomsFromTree rmtree
     case mrs of
         Just (PosRooms bounds rs) -> do
@@ -72,6 +68,9 @@ reversePair (a,b) = (b,a)
 compactDrawTree :: Tree String -> String
 compactDrawTree = unlines . compactDraw
 
+smallDrawTree :: Tree String -> String
+smallDrawTree = unlines . compactDraw'
+
 compactDraw :: Tree String -> [String]
 compactDraw (Node x [Node y ts]) = compactDraw (Node (x++","++y) ts)
 compactDraw (Node x ts0) = lines x ++ drawSubTrees ts0
@@ -82,3 +81,14 @@ compactDraw (Node x ts0) = lines x ++ drawSubTrees ts0
     drawSubTrees (t:ts) =
         "|" : shift "+- " "|  " (compactDraw t) ++ drawSubTrees ts
     shift first other = zipWith (++) (first : repeat other)
+
+compactDraw' :: Tree String -> [String]
+compactDraw' (Node x [Node y ts]) = lines x ++ ["|"] ++ compactDraw' (Node y ts)
+compactDraw' (Node x ts0) = lines x ++ drawSubTrees ts0
+  where
+    drawSubTrees [] = []
+    drawSubTrees [t] =
+        "|" : compactDraw' t
+    drawSubTrees (t:ts) =
+        "|" : shift "+- " "|  " (compactDraw' t) ++ drawSubTrees ts
+    shift first other = zipWith (++) (first : repeat other)

src/Dodge/Tree/Compose.hs

@@ -16,6 +16,7 @@ module Dodge.Tree.Compose
 --    , composeAndLog
     , toOnward
     , attachOnward
+    , showIntsString
 --    , cmpToMT
 --    , compTree
     , module Dodge.Tree.Compose.Data
@@ -27,6 +28,7 @@ import TreeHelp
 --import Dodge.Base
 import LensHelp
 
+import Data.List (intersperse)
 import Data.Tuple
 --import Data.Bifunctor
 --import Control.Monad.State
@@ -201,7 +203,7 @@ decomposeSelfTree st = fmap fst (_unST st) : concatMap (f . snd) (_unST 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 (_mtLabel mt,Left $ fmap f t) (_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)
@@ -233,6 +235,7 @@ toOnward rm
         = Just (rm & rmClusterStatus . csLinks . at OnwardCluster .~ Nothing)
     | otherwise = Nothing
 
+numSelfTree :: SelfTree a -> SelfTree ([Int],a)
 numSelfTree st = evalState (numSelfTree' st) [0]
 
 numSelfTree' :: SelfTree a -> State [Int] (SelfTree ([Int],a))
@@ -241,9 +244,8 @@ numSelfTree' (ST (Node lrt bs)) = do
     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,Left t) -> return $ ST (Node ((is,y),Left $ (_1 %~ (: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]
@@ -254,3 +256,6 @@ numMetaTree' (MTree lab mn bs) = do
     modify (ix 0 +~ 1)
     bs' <- mapM (mbTree %%~ numMetaTree') bs
     return $ MTree (is,lab) (mn & nodeMetaTree %~ (\nmt -> evalState (numMetaTree' nmt) (0:is))) bs'
+
+showIntsString :: ([Int],String) -> String
+showIntsString (is,s) = foldr1 (++) (intersperse ":" (map show is)) ++ ':':s