From 8b4b6de0c07f5aed59a4115a4b9060703cd223f3 Mon Sep 17 00:00:00 2001
From: justin <justin.g.kruger@gmail.com>
Date: Sat, 11 Jun 2022 17:25:03 +0100
Subject: [PATCH] Confirm generalised tree composition works

---
 src/Dodge/LevelGen.hs     | 9 +++++----
 src/Dodge/Tree/Compose.hs | 7 +++++++
 2 files changed, 12 insertions(+), 4 deletions(-)

diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs
index 907445375..145284f6c 100644
--- a/src/Dodge/LevelGen.hs
+++ b/src/Dodge/LevelGen.hs
@@ -36,10 +36,11 @@ layoutLevelFromSeed i seed = do
     appendFile "log/attemptedSeeds" $ show seed ++ "\n"
     let g = mkStdGen seed
     let treecluster = evalState initialRoomTree g
-        (strs,tc) = composeTree' treecluster
-    appendFile "log/TreeCluster" ("Seed: "++ show seed)
-    mapM_ (appendFile "log/treeCluster" . ('\n':))  strs
-    mapM_ putStrLn strs
+    tc <- composeAndLog $ cmpToMT treecluster
+    ----    (strs,tc) = composeTree' treecluster
+    ----appendFile "log/TreeCluster" ("Seed: "++ show seed)
+    ----mapM_ (appendFile "log/treeCluster" . ('\n':))  strs
+    ----mapM_ putStrLn strs
     --putStrLn "Room cluster layout:"
     --putStrLn $ drawTreeSubLabelling $ fmap snd treecluster
     --let rmtree = inorderNumberTree $ expandTree $ fmap fst treecluster
diff --git a/src/Dodge/Tree/Compose.hs b/src/Dodge/Tree/Compose.hs
index 6663b20d9..9a37ac256 100644
--- a/src/Dodge/Tree/Compose.hs
+++ b/src/Dodge/Tree/Compose.hs
@@ -16,6 +16,7 @@ module Dodge.Tree.Compose
     , attachTree
     , composeTreeRand
     , composeAndLog
+    , cmpToMT
 --    , compTree
     ) where
 import Dodge.Data
@@ -184,3 +185,9 @@ composeAndLog mt = case mt of
         putStrLn $ drawTree $ logMT mt
         brs <- mapM composeAndSubLog $ _btBranches mt
         return $ Node (_btValue mt) brs
+
+cmpToMT :: Tree (a-> Maybe (b,a), Tree a) -> MetaTree a
+cmpToMT (Node (_,t) ts) = MTree "A" (tToBT t) (map tToMB ts)
+  where
+    tToMB (Node (f,t') ts') = MBranch "C" (fmap snd . f) $ MTree "D" (tToBT t') (map tToMB ts')
+    tToBT (Node x xs) = BTree "B" x $ map tToBT xs