Commit before further changes to MetaTrees

src/Dodge/Tree/Compose.hs

@@ -1,15 +1,7 @@
 {-# LANGUAGE TupleSections #-}
 {-| Combining and composing trees of trees.  -}
 module Dodge.Tree.Compose
-    ( --expandTree
-    --, pure
-    --, pure
-    --, chainUses
-    --, useAllAtEnd
-    --, changeTo
-    --, applyToCompRoot
-    passUntiluseAll  -- this should be moved, and the dependency on Dodge.Data removed
-    , tToBTree
+    ( tToBTree
     , overwriteLabel
     , composeTree
     , composeTree'
@@ -17,7 +9,7 @@ module Dodge.Tree.Compose
     , attachTree
     , composeTreeRand
     , composeAndLog
-    , toOnward'
+    , toOnward
     , attachOnward
 --    , cmpToMT
 --    , compTree
@@ -63,12 +55,6 @@ overwriteLabel i t ts = safeUpdateSingleNode
 --    islabel _ = False
 --    update (Node x _) = Node (f $ _unCompose x) ts
 
-passUntiluseAll :: Tree Room -> [Tree Room] -> Tree Room
-passUntiluseAll t ts = updateAllNodes 
-    ((OnwardCluster `elem`) . (^?! rmClusterStatus . csLinks))
-    ((branches .~ ts) . (root . rmClusterStatus . csLinks . at OnwardCluster .~ Nothing))
-    t
-    
 --passUntiluseAll (Node (useAll x) _) ts' = Node ( x) ts'
 --passUntiluseAll (Node cn ts) ts' = Node ( (_unCompose cn)) $ map (`passUntiluseAll` ts') ts
 
@@ -171,23 +157,33 @@ logMT mt = case mt of
     MTree str _ brs -> Node ("M:"++str) $ map logMB brs
     BTree str _ brs -> Node str $ map logMT brs
 
-composeAndSubLog :: Monad m => (String -> m ()) -> MetaTree a -> m (Tree a)
-composeAndSubLog dolog mt = case mt of
-    MTree{} -> composeAndLog dolog mt
+composeAndSubLog :: Monad m => [Int] -> (String -> m ()) -> MetaTree a -> m (Tree a)
+composeAndSubLog is dolog mt = case mt of
+    MTree{} -> do
+        dolog ("SUBTREE"++show is++mRootLabel mt++"\n")
+        rt <- composeAndLog (0:is) dolog $ _mtTree mt
+        brs <- mapM (\(i,mb) -> (_mbAttach mb,) <$> composeAndSubLog (is & ix 0 +~ 1) dolog (_mbTree mb)) 
+            $ zip [0..] $ _mtBranches mt
+        return $ attachList rt $ map pure brs
     bt -> do
-        brs <- mapM (composeAndSubLog dolog) (_btBranches bt)
+        dolog ("SUBTREE:"++show is++mRootLabel mt++"\n")
+        dolog $ drawTree $ logMT mt
+        brs <- mapM (composeAndSubLog is dolog) (_btBranches bt)
         return $ Node (_btValue bt) brs
 
-composeAndLog :: Monad m => (String -> m ()) -> MetaTree a -> m (Tree a)
-composeAndLog dolog mt = case mt of
+composeAndLog :: Monad m => [Int] -> (String -> m ()) -> MetaTree a -> m (Tree a)
+composeAndLog is dolog mt = case mt of
     MTree{} -> do
         dolog $ drawTree $ logMT mt
-        rt <- composeAndLog dolog $ _mtTree mt
-        brs <- mapM (\mb -> (_mbAttach mb,) <$> composeAndSubLog dolog (_mbTree mb)) $ _mtBranches mt
+        dolog ("SUBTREE"++show is++mRootLabel mt++"\n")
+        rt <- composeAndLog (0:is) dolog $ _mtTree mt
+        brs <- mapM (\(i,mb) -> (_mbAttach mb,) <$> composeAndSubLog (is & ix 0 +~ 1) dolog (_mbTree mb)) 
+            $ zip [0..] $ _mtBranches mt
         return $ attachList rt $ map pure brs
     BTree{} -> do
+        dolog ("SUBTREE:"++show is++mRootLabel mt++"\n")
         dolog $ drawTree $ logMT mt
-        brs <- mapM (composeAndSubLog dolog) $ _btBranches mt
+        brs <- mapM (composeAndSubLog is dolog) $ _btBranches mt
         return $ Node (_btValue mt) brs
 
 tToBTree :: Tree Room -> MetaTree Room
@@ -195,11 +191,11 @@ tToBTree (Node r ts) = BTree (_rmName r) r $ map tToBTree ts
 
 attachOnward :: MetaTree Room -> MetaTree Room -> MetaTree Room
 attachOnward t1 t2 = case t1 of
-    MTree {} -> t1 & mtBranches .:~ MBranch "Onward" toOnward' t2
-    BTree {} -> MTree "ConstructedOnward" t1 [MBranch "Onward" toOnward' t2]
+    MTree {} -> t1 & mtBranches .:~ MBranch "Onward" toOnward t2
+    BTree {} -> MTree (mRootLabel t1 ++ "-" ++ mRootLabel t2) t1 [MBranch "Onward" toOnward t2]
 
-toOnward' :: Room -> Maybe Room
-toOnward' rm
+toOnward :: Room -> Maybe Room
+toOnward rm
     | OnwardCluster `elem` rm ^?! rmClusterStatus . csLinks 
         = Just (rm & rmClusterStatus . csLinks . at OnwardCluster .~ Nothing)
     | otherwise = Nothing

src/Dodge/Tree/Compose/Data.hs

@@ -11,6 +11,11 @@ data MetaTree a
     = MTree {_mtLabel :: String , _mtTree :: MetaTree a , _mtBranches :: [MetaBranch a] }
     | BTree {_btLabel :: String , _btValue :: a ,         _btBranches :: [MetaTree a] }
 
+mRootLabel :: MetaTree a -> String
+mRootLabel mt = case mt of
+    MTree {} -> _mtLabel mt
+    BTree {} -> _btLabel mt
+
 --type CompTree a = Tree (Tree a)
 type LabTree a = (a -> Maybe ([String],a),Tree a)
 type LabCompTree a = Tree (LabTree a)