From 6cd1d6c130556f60fabb04f044ba5a7484f9e900 Mon Sep 17 00:00:00 2001
From: justin <justin.g.kruger@gmail.com>
Date: Sat, 11 Jun 2022 17:07:58 +0100
Subject: [PATCH] Implement more general tree composition

---
 src/Dodge/Floor.hs             |  6 +++---
 src/Dodge/Tree/Compose.hs      | 26 +++++++++++++++++++++++++-
 src/Dodge/Tree/Compose/Data.hs | 19 +++++++++++--------
 3 files changed, 39 insertions(+), 12 deletions(-)

diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs
index 50dae21d0..dd6cb600e 100644
--- a/src/Dodge/Floor.hs
+++ b/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))
diff --git a/src/Dodge/Tree/Compose.hs b/src/Dodge/Tree/Compose.hs
index aab6de87f..4d3ff3675 100644
--- a/src/Dodge/Tree/Compose.hs
+++ b/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
diff --git a/src/Dodge/Tree/Compose/Data.hs b/src/Dodge/Tree/Compose/Data.hs
index 804496175..7d7573812 100644
--- a/src/Dodge/Tree/Compose/Data.hs
+++ b/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}
---    | useAll    {_unCompose :: a}
-    | UseSome   {_composeIndices :: [Int], _unCompose :: a}
-    | UseNone   {_unCompose :: a}
---    | useLabel  {_composeIndex :: Int, _unCompose :: a} -- defaults to using no children
-type CompTree a = Tree (Tree a)
+
+data MetaBranch a 
+    = MBranch {_mbLabel :: String, _mbAttach :: a -> Maybe a, _mbTree :: MetaTree a}
+
+data MetaTree a
+    = MTree {_mtLabel :: String , _mtTree :: MetaTree a , _mtBranches :: [MetaBranch 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